home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 9 / Night Owl CD-ROM (NOPV9) (Night Owl Publisher) (1993).ISO / 023a / advsrc.zip / ADVENTUR.FOR < prev    next >
Text File  |  1993-04-08  |  82KB  |  2,355 lines
  1. c  =====================================================================
  2. c  Adventure!
  3. c  =====================================================================
  4. c   Modified for MS DOS PDS FORTRAN v5.10 
  5. c    by Paul Muñoz-Colman, FunStuff Software
  6. c   27 Mar 1993  change date & time to getdat & gettim
  7. c                delete DO66 and DEBUG metacommands
  8. c                change pause prompt
  9. c                change OPEN STATUS to UNKNOWN on overwrites
  10. c   15 Oct 1990  fix abort in line 653 from using the "say" verb
  11. c   13 Oct 1987  with suspend and resume feature--2-byte storage
  12. c  =====================================================================
  13. c
  14. c  Differences from Honeywell version to live with MS FORTRAN 77:
  15. c    1.  Can't EQUIVALENCE anything in COMMON or storage is bad.
  16. c    2.  LOGICAL functions can't have integer arguments--doesn't work.
  17. c        All were rewritten to be INTEGER functions (1=true,0=false)
  18. c    3.  Data Base is binary file written by separate program to
  19. c        save space and time.  Limited to 64K.  I/O is slowww...
  20. c    4.  SAVE feature saves data arrays instead of whole program.
  21. c        RESUME must be given first turn, which reads file.
  22. c    5.  Demonstration game and wizard stuff is gone...stupid anyway..
  23. c
  24. c  Current limits:
  25. c   21150 words of message text (lines, linsiz)
  26. c     745 travel options (travel, trvsiz).
  27. c     295 vocabulary words (ktab, atab, tabsiz).
  28. c     150 locations (ltext, stext, key, cond, abb, atloc, locsiz).
  29. c     100 objects (plac, place, fixd, fixed, link (twice), ptext, prop)
  30. c      35 "action" verbs (actspk, vrbsiz).
  31. c     205 random messages (rtext, rtxsiz).
  32. c      12 different player classifications (ctext, cval, clsmax).
  33. c      20 hints, less 3 (hintlc, hinted, hints, hntsiz).
  34. c
  35. c  there are also limits which cannot be exceeded due to the structure of
  36. c  the database.  (e.g., the vocabulary uses n/1000 to determine word type,
  37. c  so there can't be more than 1000 words.)  these upper limits are:
  38. c  1000 non-synonymous vocabulary words
  39. c  300 locations
  40. c  100 objects
  41. c
  42. c  set metacommands for ms fortran
  43. $nodebug
  44. $notstrict
  45. $storage: 2
  46. c
  47.       implicit integer*2 (a-z)
  48. c
  49.       common /txtcom/ rtext
  50.       common /blkcom/ blklin
  51.       common /voccom/ ktab,atab,tabsiz
  52.       common /placom/ atloc,link,place,fixed,holdng
  53.       common /ptxcom/ ptext
  54.       common /abbcom/ abb
  55.       common /concom/ cond
  56.       common /loccom/ loc
  57.       common /procom/ prop, lamp
  58.       common /lincom/ lines
  59.       character*2 lines (21150)
  60.       character*4 wd1,wd2,iz,bl,atab(295),wd1x,wd2x
  61.       character*1 tk(20)
  62. c
  63.       integer*2 ktab(295),rtext(205),atloc(150)
  64.       integer*2 ltext(150),stext(150),key(150),cond(150),abb(150)
  65.       integer*2 plac(100),place(100),fixd(100),fixed(100),link(200)
  66.       integer*2 actspk(35),ptext(100),prop(100),ctext(12),cval(12)
  67.       integer*2 hintlc(20),hinted(20),hints(20,4),dseen(6),dloc(6)
  68.       integer*2 idondx,odloc(6)
  69.       integer*4 travel(745),itk(20),newloc,linuse,kk,linsiz
  70.       integer*4 ll,izz
  71. c
  72.       equivalence(izz,iz)
  73. c
  74.       external ran
  75. c
  76.       data linsiz/21150/,trvsiz/745/,locsiz/150/,izz/0/,
  77.      .        vrbsiz/35/,rtxsiz/205/,clsmax/12/,hntsiz/20/
  78.       data bl/'    '/
  79. c
  80. c  various functions--all integer in ms fortran--1 true  0 false
  81. c  some are statement functions--others independently compiled
  82.       bitset(l,n)=mod(shift(cond(l),-n),2)
  83.       liq2(pbotl)=(1-pbotl)*water+(pbotl/2)*(water+oil)
  84.       liqloc(loc)=liq2((mod(cond(loc)/2*2,8)-5)*mod(cond(loc)/4,2)+1)
  85.       liq(dummy)=liq2(max0(prop(bottle),-1-prop(bottle)))
  86. c
  87. c  toting(obj) = true if the obj is being carried
  88. c  here(obj)   = true if the obj is at "loc" (or is being carried)
  89. c  at(obj)     = true if on either side of two-placed object
  90. c  liq(dummy)  = object number of liquid in bottle
  91. c  liqloc(loc) = object number of liquid (if any) at loc
  92. c  bitset(l,n) = true if cond(l) has bit n set (bit 0 is units bit)
  93. c  forced(loc) = true if loc moves without asking for input (cond=2)
  94. c  dark(dummy) = true if location "loc" is dark
  95. c  pct(n)      = true n% of the time (n integer*2 from 0 to 100)
  96. c  wzdark says whether the loc he's leaving was dark
  97. c  lmwarn says whether he's been warned about lamp going dim
  98. c  closng says whether its closing time yet
  99. c  panic says whether he's found out he's trapped in the cave
  100. c  closed says whether we're all the way closed
  101. c  gaveup says whether he exited via "quit"
  102. c  scorng indicates to the score routine whether we're doing a "score" command
  103. c  yea is random yes/no reply
  104.  
  105. c  description of the database format
  106. c  the data file contains several sections.  each begins with a line containing
  107. c  a number identifying the section, and ends with a line containing "-1".
  108. c
  109. c  section 1: long form descriptions.  each line contains a location number,
  110. c  and a line of text.  the set of (necessarily adjacent) lines
  111. c  whose numbers are x form the long description of location x.
  112. c
  113. c  section 2: short form descriptions.  same format as long form.  not all
  114. c  places have short descriptions.
  115. c
  116. c  section 3: travel table.  each line contains a location number (x), a second
  117. c  location number (y), and a list of motion numbers (see section 4).
  118. c  each motion represents a verb which will go to y if currently at x.
  119. c  y, in turn, is interpreted as follows.  let m=y/1000, n=y mod 1000.
  120. c      if n<=300     it is the location to go to.
  121. c      if 300<n<=500 n-300 is used in a computed goto to
  122. c                           a section of special code.
  123. c      if n>500      message n-500 from section 6 is printed,
  124. c                           and he stays wherever he is.
  125. c  meanwhile, m specifies the conditions on the motion.
  126. c      if m=0        it's unconditional.
  127. c      if 0<m<100    it is done with m% probability.
  128. c      if m=100      unconditional, but forbidden to dwarves.
  129. c      if 100<m<=200 he must be carrying object m-100.
  130. c      if 200<m<=300 must be carrying or in same room as m-200.
  131. c      if 300<m<=400 prop(m mod 100) must *not* be 0.
  132. c      if 400<m<=500 prop(m mod 100) must *not* be 1.
  133. c      if 500<m<=600 prop(m mod 100) must *not* be 2, etc.
  134. c
  135. c  if the condition (if any) is not met, then the next *different*
  136. c  "destination" value is used (unless it fails to meet *its* conditions,
  137. c  in which case the next is found, etc.).  typically, the next dest will
  138. c  be for one of the same verbs, so that its only use is as the alternate
  139. c  destination for those verbs.  for instance:
  140. c      15     110022 29     31     34     35     23     43
  141. c      15     14     29
  142. c  this says that, from loc 15, any of the verbs 29, 31, etc1. will take
  143. c  him to 22 if he's carrying object 10, and otherwise will go to 14.
  144. c      11     303008 49
  145. c      11     9      50
  146. c  this says that, from 11, 49 takes him to 8 unless prop(3)=0, in which
  147. c  case he goes to 9.  verb 50 takes him to 9 regardless of prop(3).
  148. c
  149. c  section 4: vocabulary.  each line contains a number (n), and a
  150. c  five-letter word.  call m=n/1000.  if m=0, then the word is a motion
  151. c  verb for use in travelling (see section 3).  else, if m=1, the word is
  152. c  an object.  else, if m=2, the word is an action verb (such as "carry"
  153. c  or "attack").  else, if m=3, the word is a special case verb (such as
  154. c  "dig") and n mod 1000 is an index into section 6.  objects from 50 to
  155. c  (currently, anyway) 79 are considered treasures (for pirate, closeout).
  156. c
  157. c  section 5: object descriptions.  each line contains a number (n),
  158. c  and a message.  if n is from 1 to 100, the message is the "inventory"
  159. c  message for object n.  otherwise, n should be 000, 100, 200, etc., and
  160. c  the message should be the description of the preceding object when its
  161. c  prop value is n/100.  the n/100 is used only to distinguish multiple
  162. c  messages from multi-line messages; the prop info actually requires all
  163. c  messages for an object to be present and consecutive.  properties which
  164. c  produce no message should be given the message ">$<".
  165. c
  166. c  section 6: arbitrary messages.  same format as sections 1, 2, and 5, except
  167. c  the numbers bear no relation to anything (except for special verbs
  168. c  in section 4).
  169. c
  170. c  section 7: object locations.  each line contains an object number and its
  171. c  initial location (zero (or omitted) if none).  if the object is
  172. c  immovable, the location is followed by a "-1".  if it has two locations
  173. c  (e.g. the grate) the first location is followed with the second, and
  174. c  the object is assumed to be immovable.
  175. c
  176. c  section 8: action defaults.  each line contains an "action-verb" number and
  177. c  the index (in section 6) of the default message for the verb.
  178. c
  179. c  section 9: liquid assets, etc.  each line contains a number (n) and up to 20
  180. c  location numbers.  bit n (where 0 is the units bit) is set in cond(loc)
  181. c  for each loc given.  the cond bits currently assigned are:
  182. c      0      light
  183. c      1      if bit 2 is on: on for oil, off for water
  184. c      2      liquid asset, see bit 1
  185. c      3      pirate doesn't go here unless following player
  186. c  other bits are used to indicate areas of interest to "hint" routines:
  187. c      4      trying to get into cave
  188. c      5      trying to catch bird
  189. c      6      trying to deal with snake
  190. c      7      lost in maze
  191. c      8      pondering dark room
  192. c      9      at witt's end
  193. c  cond(loc) is set to 2, overriding all other bits, if loc has forced
  194. c  motion.
  195. c
  196. c  section 10: class messages.  each line contains a number (n), and a
  197. c  message describing a classification of player.  the scoring section
  198. c  selects the appropriate message, where each message is considered to
  199. c  apply to players whose scores are higher than the previous n but not
  200. c  higher than this n.  note that these scores probably change with every
  201. c  modification (and particularly expansion) of the program.
  202. c
  203. c  section 11: hints.  each line contains a hint number (corresponding to a
  204. c  cond bit, see section 9), the number of turns he must be at the right
  205. c  loc(s) before triggering the hint, the points deducted for taking the
  206. c  hint, the message number (section 6) of the question, and the message
  207. c  number of the hint.  these values are stashed in the "hints" array.
  208. c  hntmax is set to the max hint number (<= hntsiz).  numbers 1-3 are
  209. c  unusable since cond bits are otherwise assigned, so 2 is used to
  210. c  remember if he's read the clue in the repository, and 3 is used to
  211. c  remember whether he asked for instructions (gets more turns, but loses
  212. c  points).
  213. c
  214. c  section 12: magic messages. not implemented ibm pc version.  stupid.
  215. c
  216. c  section 0: end of database.
  217. c
  218. c  clear out the various text-pointer arrays.  all text is stored in array
  219. c  lines; each line is preceded by a word pointing to the next pointer (i.e.
  220. c  the word following the end of the line).  the pointer is negative if this is
  221. c  first line of a message.  the text-pointer arrays contain indices of
  222. c  pointer-words in lines.  stext(n) is short description of location n.
  223. c  ltext(n) is long description.  ptext(n) points to message for prop(n)=0.
  224. c  successive prop messages are found by chasing pointers.  rtext contains
  225. c  section 6's stuff.  ctext(n) points to a player-class message.
  226. c  we also clear cond.  see description of section 9 for details.
  227. c
  228. c  the stuff for section 3 is encoded here.  each "from-location" gets a
  229. c  contiguous section of the "travel" array.  each entry in travel is
  230. c  newloc*1000 + keyword (from section 4, motion verbs), and is negated if
  231. c  this is the last entry for this location.  key(n) is the index in travel
  232. c  of the first option at location n.
  233.  
  234. c  here we read in the vocabulary.  ktab(n) is the word number, atab(n) is
  235. c  the corresponding word.  the -1 at the end of section 4 is left in ktab
  236. c  as an end-marker.
  237.  
  238. c  read in the initial locations for each object.  also the immovability info.
  239. c  plac contains initial locations of objects.  fixd is -1 for immovable
  240. c  objects (including the snake), or = second loc for two-placed objects.
  241.  
  242. c  read default message numbers for action verbs, store in actspk.
  243.  
  244. c  read info about available liquids and other conditions, store in cond.
  245.  
  246. c  read data for hints.
  247.  
  248. c  having read in the database, certain things are now constructed.  props are
  249. c  set to zero.  we finish setting up cond by checking for forced-motion travel
  250. c  entries.  the plac and fixd arrays are used to set up atloc(n) as the first
  251. c  object at location n, and link(obj) as the next object at the same location
  252. c  as obj.  (obj>100 indicates that fixed(obj-100)=loc; link(obj) is still the
  253. c  correct link to use.)  abb is zeroed; it controls whether the abbreviated
  254. c  description is printed.  counts mod 5 unless "look" is used.
  255.  
  256. c  set up the atloc and link arrays as described above.  we'll use the drop
  257. c  suboutine, which prefaces new objects on the lists.  since we want things
  258. c  in the other order, we'll run the loop backwards.  if the object is in two
  259. c  locs, we drop it twice.  this also sets up "place" and "fixed" as copies of
  260. c  "plac" and "fixd".  also, since two-placed objects are typically best
  261. c  described last, we'll drop them first.
  262.  
  263. c  treasures, as noted earlier, are objects 50 through maxtrs (currently 79).
  264. c  their props are initially -1, and are set to 0 the first time they are
  265. c  described.  tally keeps track of how many are not yet found, so we know
  266. c  when to close the cave.  tally2 counts how many can never be found (e.g. if
  267. c  lost bird or bridge).
  268.  
  269. c  clear the hint stuff.  hintlc(i) is how long he's been at loc with cond bit
  270. c  i.  hinted(i) is true iff hint i has been used.
  271.  
  272. c  define some handy mnemonics.  these correspond to object numbers.
  273.  
  274. c  objects from 50 through whatever are treasures.  here are a few.
  275.  
  276. c  these are motion-verb numbers.
  277.  
  278. c  and some action verbs.
  279.  
  280. c  initialize the dwarves.  dloc is loc of dwarves, hard-wired in.  odloc is
  281. c  prior loc of each dwarf, initially garbage.  daltlc is alternate initial loc
  282. c  for dwarf, in case one of them starts out on top of the adventurer.  (no 2
  283. c  of the 5 initial locs are adjacent.)  dseen is true if dwarf has seen him.
  284. c  dflag controls the level of activation of all this:
  285. c    0      no dwarf stuff yet (wait until reaches hall of mists)
  286. c    1      reached hall of mists, but hasn't met first dwarf
  287. c    2      met first dwarf, others start moving, no knives thrown yet
  288. c    3      a knife has been thrown (first set always misses)
  289. c    3+     dwarves are mad (increases their accuracy)
  290. c  sixth dwarf is special (the pirate).  he always starts at his chest's
  291. c  eventual location inside the maze.  this loc is saved in chloc for ref.
  292. c  the dead end in the other maze has its loc stored in chloc2.
  293.  
  294. c  other random flags and counters, as follows:
  295. c  turns  tallies how many commands he's given (ignores yes/no)
  296. c  limit  lifetime of lamp (not set here)
  297. c  iwest  how many times he's said "west" instead of "w"
  298. c  knfloc 0 if no knife here, loc if knife here, -1 after caveat
  299. c  detail how often we've said "not allowed to give more detail"
  300. c  abbnum how often we should print non-abbreviated descriptions
  301. c  maxdie number of reincarnation messages available (up to 5)
  302. c  numdie number of times killed so far
  303. c  holdng number of objects being carried
  304. c  dkill  number of dwarves killed (unused in scoring, needed for msg)
  305. c  foobar current progress in saying "fee fie foe foo".
  306. c  bonus  used to determine amount of bonus if he reaches closing
  307. c  clock1 number of turns from finding last treasure till closing
  308. c  clock2 number of turns from first warning till blinding flash
  309. c  logicals were explained earlier
  310.  
  311. c  read the database--resume restores variables at 8305 and proceeds
  312. c
  313.       write (*,1000)
  314.  1000 format(//////////////,
  315.      .           ' Adventure!  (The original Colossal Cave!)',
  316.      .       ///,'     (Implemented for MS DOS in PDS FORTRAN v5.10',
  317.      .         /,'      by Paul Muñoz-Colman, FunStuff Software.',
  318.      .    /,'      Version 27 March 1993.)',
  319.      .  ////////,' Initializing, Please Wait ...')
  320. c
  321.       open (1, file='ad.dat', form='unformatted')
  322. c
  323. c  read the data base in array format
  324. c
  325.       read (1) abbnum,axe,back,batter,bear,bird,bonus,bottle,
  326.      .  cage,cave,chain,chasm,chest,chloc,chloc2,clam,
  327.      .  clock1,clock2,closed,closng,coins,daltlc,detail,dflag,
  328.      .  dkill,dloc,door,dprssn,dragon,dseen,dwarf,eggs,
  329.      .  emrald,entrnc,find,fissur,foobar,food,gaveup,grate
  330. c
  331.       read (1) invent,iwest,keys,knfloc,knife,lamp,lmwarn,
  332.      .  lock,look,magzin,maxdie,maxtrs,messag,mirror,nugget,
  333.      .  null,numdie,oil,oyster,panic,pearl,pillow,plant,
  334.      .  plant2,pyram,rod,rod2,rug,saved,say,scorng,
  335.      .  snake,spices,steps,tablet,tally,tally2,throw,tridnt,
  336.      .  troll,troll2,turns,vase,vend,water,tabsiz,blklin,oldloc,fixed
  337. c
  338.       read (1) linuse,trvs,tabndx,obj,verb,clsses,hntmax,loc,newloc,
  339.      .  k,j,stext,ltext,ptext,rtext,ctext,cval,key,
  340.      .  travel,ktab,plac,fixd,actspk,cond,hints,place,prop,link,
  341.      .  abb,atloc,holdng,hinted,hintlc,kk,i,itk,atab,lines
  342. c
  343.       close (1)
  344.  
  345.       write (*,10001)
  346. 10001 format('+                                    ')
  347.  
  348. c  start-up, dwarf stuff
  349. c
  350.  1    i=ran(1)
  351.       hinted(3)=yes(65,1,0)
  352.       newloc=1
  353.       limit=330
  354.       if(hinted(3).eq.1)limit=1000
  355.  
  356. c  can't leave cave once it's closing (except by main office).
  357.  
  358.  2    if(newloc.ge.9.or.newloc.eq.0.or.closng.eq.0) go to 71
  359.       call rspeak(130)
  360.       newloc=loc
  361.       if(panic.eq.0)clock2=15
  362.       panic=1
  363.  
  364. c  see if a dwarf has seen him and has come from where he wants to go.  if so,
  365. c  the dwarf's blocking his way.  if coming from place forbidden to pirate
  366. c  (dwarves rooted in place) let him get out (and attacked).
  367.  
  368.  71   if(newloc.eq.loc.or.forced(loc).eq.1.or.bitset(loc,3).eq.1)goto74
  369.       do 73 i=1,5
  370.       if(odloc(i).ne.newloc.or.dseen(i).eq.0)goto 73
  371.       newloc=loc
  372.       call rspeak(2)
  373.       goto 74
  374.  73   continue
  375.  74   loc=newloc
  376.  
  377. c  dwarf stuff.  see earlier comments for description of variables.  remember
  378. c  sixth dwarf is pirate and is thus very different except for motion rules.
  379.  
  380. c  first off, don't let the dwarves follow him into a pit or a wall.  activate
  381. c  the whole mess the first time he gets as far as the hall of mists (loc 15).
  382. c  if newloc is forbidden to pirate (in particular, if it's beyond the troll
  383. c  bridge), bypass dwarf stuff.  that way pirate can't steal return toll, and
  384. c  dwarves can't meet the bear.  also means dwarves won't follow him into dead
  385. c  end in maze, but c'est la vie.  they'll wait for him outside the dead end.
  386.  
  387.       nl=newloc
  388.       if(loc.eq.0.or.forced(loc).eq.1.or.bitset(nl,3).eq.1)goto2000
  389.       if(dflag.ne.0)goto 6000
  390.       if(loc.ge.15)dflag=1
  391.       goto 2000
  392.  
  393. c  when we encounter the first dwarf, we kill 0, 1, or 2 of the 5 dwarves.  if
  394. c  any of the survivors is at loc, replace him with the alternate.
  395.  
  396.  6000 if(dflag.ne.1)goto 6010
  397.       if(loc.lt.15.or.pct(95).eq.1)goto 2000
  398.       dflag=2
  399.       do 6001 i=1,2
  400.       j=1+ran(5)
  401.  6001 if(pct(50).eq.1) dloc(j)=0
  402.       do 6002 i=1,5
  403.       if(dloc(i).eq.loc)dloc(i)=daltlc
  404.  6002 odloc(i)=dloc(i)
  405.       call rspeak(3)
  406.       call drop(axe,loc)
  407.       goto 2000
  408.  
  409. c  things are in full swing.  move each dwarf at random, except if he's seen us
  410. c  he sticks with us.  dwarves never go to locs <15.  if wandering at random,
  411. c  they don't back up unless there's no alternative.  if they don't have to
  412. c  move, they attack.  and, of course, dead dwarves don't do much of anything.
  413.  
  414.  6010 dtotal=0
  415.       attack=0
  416.       stick=0
  417.       do 6030 i=1,6
  418.       if(dloc(i).eq.0)goto 6030
  419.       j=1
  420.       kk=dloc(i)
  421.       kk=key(kk)
  422.       if(kk.eq.0)goto 6016
  423.  6012 newloc=mod(iabs(travel(kk))/1000,1000)
  424.       nl=newloc
  425.       trv=iabs(travel(kk))/1000000
  426.       itk2=itk(j-1)
  427.       if(nl.gt.300.or.nl.lt.15.or.nl.eq.odloc(i)
  428.      .   .or.(j.gt.1.and.nl.eq.itk2) .or.j.ge.20
  429.      .   .or.nl.eq.dloc(i).or.forced(nl).eq.1
  430.      .   .or.(i.eq.6.and.bitset(nl,3).eq.1)
  431.      .   .or.trv.eq.100) go to 6014
  432.       itk(j)=newloc
  433.       j=j+1
  434.  6014 kk=kk+1
  435.       if(travel(kk-1).ge.0)goto 6012
  436.  6016 itk(j)=odloc(i)
  437.       if(j.ge.2)j=j-1
  438.       j=1+ran(j)
  439.       odloc(i)=dloc(i)
  440.       dloc(i)=itk(j)
  441.       zzz=0
  442.       if (dseen(i).eq.1.and.loc.ge.15) zzz=1
  443.       dseen(i)=0
  444.       if (zzz.eq.1.or.(dloc(i).eq.loc.or.odloc(i).eq.loc))dseen(i)=1
  445.       if(dseen(i).eq.0) go to 6030
  446.       dloc(i)=loc
  447.       if(i.ne.6)goto 6027
  448.  
  449. c  the pirate's spotted him.  he leaves him alone once we've found chest.
  450. c  k counts if a treasure is here.  if not, and tally=tally2 plus one for
  451. c  an unseen chest, let the pirate be spotted.
  452.  
  453.       if(loc.eq.chloc.or.prop(chest).ge.0)goto 6030
  454.       k=0
  455.       do 6020 j=50,maxtrs
  456. c  pirate won't take pyramid from plover room or dark room (too easy!).
  457.       if(j.eq.pyram.and.(loc.eq.plac(pyram)
  458.      .   .or.loc.eq.plac(emrald)))goto 6020
  459.       idondx=j
  460.       if(toting(idondx).eq.1)goto 6022
  461.  6020 if(here(idondx).eq.1)k=1
  462.       if(tally.eq.tally2+1.and.k.eq.0.and.place(chest).eq.0
  463.      .   .and.here(lamp).eq.1.and.prop(lamp).eq.1)goto 6025
  464.       if(odloc(6).ne.dloc(6).and.pct(20).eq.1)call rspeak(127)
  465.       goto 6030
  466.  
  467.  6022 call rspeak(128)
  468. c  don't steal chest back from troll!
  469.       if(place(messag).eq.0)call move(chest,chloc)
  470.       call move(messag,chloc2)
  471.       do 6023 j=50,maxtrs
  472.       if(j.eq.pyram.and.(loc.eq.plac(pyram)
  473.      .   .or.loc.eq.plac(emrald)))goto 6023
  474.       idondx=j
  475.       if(at(idondx).eq.1.and.fixed(idondx).eq.0)
  476.      .  call carry(idondx,loc)
  477.       if(toting(idondx).eq.1)call drop(idondx,chloc)
  478.  6023 continue
  479.  6024 dloc(6)=chloc
  480.       odloc(6)=chloc
  481.       dseen(6)=0
  482.       goto 6030
  483.  
  484.  6025 call rspeak(186)
  485.       call move(chest,chloc)
  486.       call move(messag,chloc2)
  487.       goto 6024
  488.  
  489. c  this threatening little dwarf is in the room with him!
  490.  
  491.  6027 dtotal=dtotal+1
  492.       if(odloc(i).ne.dloc(i))goto 6030
  493.       attack=attack+1
  494.       if(knfloc.ge.0)knfloc=loc
  495.       if(ran(1000).lt.95*(dflag-2))stick=stick+1
  496.  6030 continue
  497.  
  498. c  now we know what's happening.  let's tell the poor sucker about it.
  499.  
  500.       if(dtotal.eq.0)goto 2000
  501.       if(dtotal.eq.1)goto 75
  502.       write (*,67) dtotal
  503.  67   format(/' There are ',i1,' THREATENING LITTLE DWARVES in the'
  504.      .,' room with you.')
  505.       goto 77
  506.  75   call rspeak(4)
  507.  77   if(attack.eq.0)goto 2000
  508.       if(dflag.eq.2)dflag=3
  509.       if(attack.eq.1)goto 79
  510.       write (*,78) attack
  511.  78   format(/' ',i1,' of them THROW KNIVES at you!')
  512.       k=6
  513.  82   if(stick.gt.1)goto 83
  514.       call rspeak(k+stick)
  515.       if(stick.eq.0)goto 2000
  516.       goto 84
  517.  83   write (*,68) stick
  518.  68   format(/' ',i1,' of them get you!')
  519.  84   oldlc2=loc
  520.       goto 99
  521.  
  522.  79   call rspeak(5)
  523.       k=52
  524.       goto 82
  525. c  describe the current location and (maybe) get next command.
  526.  
  527. c  print text for current loc.
  528.  
  529.  2000 if(loc.eq.0)goto 99
  530.       kk=stext(loc)
  531.       if(mod(abb(loc),abbnum).eq.0.or.kk.eq.0)kk=ltext(loc)
  532.       if(forced(loc).eq.1.or.dark(0).eq.0)goto 2001
  533.       if(wzdark.eq.1.and.pct(35).eq.1)goto 90
  534.       kk=rtext(16)
  535.  2001 if(toting(bear).eq.1)call rspeak(141)
  536.       kk2=kk
  537.       call speak(kk2)
  538.       k=1
  539.       if(forced(loc).eq.1)goto 8
  540.       if(loc.eq.33.and.pct(25).eq.1.and.closng.eq.0)call rspeak(8)
  541.  
  542. c  print out descriptions of objects at this location.  if not closing and
  543. c  property value is negative, tally off another treasure.  rug is special
  544. c  case; once seen, its prop is 1 (dragon on it) till dragon is killed.
  545. c  similarly for chain; prop is initially 1 (locked to bear).  these hacks
  546. c  are because prop=0 is needed to get full score.
  547.  
  548.       if(dark(0).eq.1)goto 2012
  549.       abb(loc)=abb(loc)+1
  550.       i=atloc(loc)
  551.       blklin=1
  552.  2004 if(i.eq.0)goto 2012
  553.       obj=i
  554.       if(obj.gt.100)obj=obj-100
  555.       if(obj.eq.steps.and.toting(nugget).eq.1)goto 2008
  556.       if(prop(obj).ge.0)goto 2006
  557.       if(closed.eq.1)goto 2008
  558.       prop(obj)=0
  559.       if(obj.eq.rug.or.obj.eq.chain)prop(obj)=1
  560.       tally=tally-1
  561. c  if remaining treasures too elusive, zap his lamp.
  562.       if(tally.eq.tally2.and.tally.ne.0)limit=min0(35,limit)
  563.  2006 kk=prop(obj)
  564.       if(obj.eq.steps.and.loc.eq.fixed(steps))kk=1
  565.       kk2=kk
  566.       call pspeak(obj,kk2)
  567.       if (blklin.eq.1) blklin=0
  568.  2008 i=link(i)
  569.       goto 2004
  570.  
  571.  2009 k=54
  572.  2010 spk=k
  573.  2011 call rspeak(spk)
  574.  
  575.  2012 verb=0
  576.       obj=0
  577.       blklin=1
  578.  
  579. c  check if this loc is eligible for any hints.  if been here long enough,
  580. c  branch to help section (on later page).  hints all come back here eventually
  581. c  to finish the loop.  ignore "hints" < 4 (special stuff, see database notes).
  582.  
  583.  2600 do 2602 hint=4,hntmax
  584.       if(hinted(hint).eq.1)goto 2602
  585.       idondx=hint
  586.       if(bitset(loc,idondx).eq.0)hintlc(hint)=-1
  587.       hintlc(hint)=hintlc(hint)+1
  588.       if(hintlc(hint).ge.hints(hint,1))goto 40000
  589.  2602 continue
  590.  
  591. c  kick the random number generator just to add variety to the chase.  also,
  592. c  if closing time, check for any objects being toted with prop < 0 and set
  593. c  the prop to -1-prop.  this way objects won't be described until they've
  594. c  been picked up and put down seperate from their seperate piles.  don't
  595. c  tick clock1 unless well into cave (and not at y2).
  596. c
  597. 26021 continue
  598.       if(closed.eq.0)goto 2605
  599.       if(prop(oyster).lt.0.and.toting(oyster).eq.1)
  600.      .   call pspeak(oyster,1)
  601.       do 2604 i=1,100
  602.       idondx=i
  603.  2604 if(toting(idondx).eq.1.and.prop(idondx).lt.0)
  604.      .   prop(idondx)=-1-prop(idondx)
  605.  2605 wzdark=dark(0)
  606.       if(knfloc.gt.0.and.knfloc.ne.loc)knfloc=0
  607.       i=ran(1)
  608.       call getin(wd1,wd1x,wd2,wd2x)
  609.  
  610. c  every input, check "foobar" flag.  if zero, nothing's going on.  if pos,
  611. c  make neg.  if neg, he skipped a word, so make it zero.
  612.  
  613.  2608 foobar=min0(0,-foobar)
  614.       if (turns.eq.0.and.wd1.eq.'resu')go to 8305
  615.       turns=turns+1
  616.       if(verb.eq.say.and.wd2.ne.iz)verb=0
  617.       if(verb.eq.say)goto 4090
  618.       if(tally.eq.0.and.loc.ge.15.and.loc.ne.33)clock1=clock1-1
  619.       if(clock1.eq.0)goto 10000
  620.       if(clock1.lt.0)clock2=clock2-1
  621.       if(clock2.eq.0)goto 11000
  622.       if(prop(lamp).eq.1)limit=limit-1
  623.       if(limit.le.30.and.here(batter).eq.1.and.prop(batter).eq.0
  624.      . .and.here(lamp).eq.1)goto 12000
  625.       if(limit.eq.0)goto 12400
  626.       if(limit.lt.0.and.loc.le.8)goto 12600
  627.       if(limit.le.30)goto 12200
  628. 19999  k=43
  629.       if(liqloc(loc).eq.water)k=70
  630.       if(wd1.eq.'ente'.and.(wd2.eq.'stre'.or.wd2.eq.'wate'))
  631.      .   goto 2010
  632.       if(wd1.eq.'ente'.and.wd2.ne.iz)goto 2800
  633.       if((wd1.ne.'wate'.and.wd1.ne.'oil ')
  634.      . .or.(wd2.ne.'plan'.and.wd2.ne.'door'))goto 2610
  635.       if(at(vocab(wd2,1)).eq.1)wd2='pour'
  636.  2610 if(wd1.ne.'west')goto 2630
  637.       iwest=iwest+1
  638.       if(iwest.eq.10)call rspeak(17)
  639.  2630 i=vocab(wd1,-1)
  640.       if(i.eq.-1)goto 3000
  641.       k=mod(i,1000)
  642.       kq=i/1000+1
  643.       if(kq.gt.4) call bug(22)
  644.       goto (8,5000,4000,2010),kq
  645.  
  646. c  get second word for analysis.
  647.  
  648.  2800 wd1=wd2
  649.       wd1x=wd2x
  650.       wd2=iz
  651.       goto 2610
  652.  
  653. c  gee, i don't understand.
  654.  
  655.  3000 spk=60
  656.       if(pct(20).eq.1)spk=61
  657.       if(pct(20).eq.1)spk=13
  658.       call rspeak(spk)
  659.       goto 2600
  660.  
  661. c  analyze a verb.  remember what it was, go back for object if second word
  662. c  unless verb is "say", which snarfs arbitrary second word.
  663.  
  664.  4000 verb=k
  665.       spk=actspk(verb)
  666.       if(wd2.ne.iz.and.verb.ne.say)goto 2800
  667.       if(verb.eq.say)obj=wd2
  668.       if(verb.gt.31)call bug(23)
  669.       if(obj.ne.0)goto 4090
  670.  
  671. c  analyze an intransitive verb (ie, no object given yet).
  672.  
  673.  4080 goto(8010,8000,8000,8040,2009,8040,9070,9080,8000,8000,
  674.      .    2011,9120,9130,8140,9150,8000,8000,8180,8000,8200,
  675.      .    8000,9220,9230,8240,8250,8260,8270,8000,8000,8300,
  676.      .    8310),verb
  677. c         take drop  say open noth lock   on  off wave calm
  678. c         walk kill pour  eat drnk  rub toss quit find invn
  679. c         feed fill blst scor  foo  brf read brek wake susp
  680. c         hour
  681.  
  682. c  analyze a transitive verb.
  683.  
  684.  4090 goto(9010,9020,9030,9040,2009,9040,9070,9080,9090,2011,
  685.      .    2011,9120,9130,9140,9150,9160,9170,2011,9190,9190,
  686.      .    9210,9220,9230,2011,2011,2011,9270,9280,9290,2011,
  687.      .    2011),verb
  688. c         take drop  say open noth lock   on  off wave calm
  689. c         walk kill pour  eat drnk  rub toss quit find invn
  690. c         feed fill blst scor  foo  brf read brek wake susp
  691. c         hour
  692.  
  693. c  analyze an object word.  see if the thing is here, whether we've got a verb
  694. c  yet, and so on.  object must be here unless verb is "find" or "invent(ory)"
  695. c  (and no new verb yet to be analyzed).  water and oil are also funny, since
  696. c  they are never actually dropped at any location, but might be here inside
  697. c  the bottle or as a feature of the location.
  698.  
  699.  5000 obj=k
  700.       if(fixed(k).ne.loc.and.here(k).eq.0)goto 5100
  701.  5010 if(wd2.ne.iz)goto 2800
  702.       if(verb.ne.0)goto 4090
  703.       call a5toa1(wd1,wd1x,'?   ','    ',tk,k)
  704.       write (*,5015) (tk(i),i=1,k)
  705.  5015 format(/' What do you want to do with the ',20a1)
  706.       goto 2600
  707.  
  708.  5100 if(k.ne.grate)goto 5110
  709.       if(loc.eq.1.or.loc.eq.4.or.loc.eq.7)k=dprssn
  710.       if(loc.gt.9.and.loc.lt.15)k=entrnc
  711.       if(k.ne.grate)goto 8
  712.  5110 if(k.ne.dwarf)goto 5120
  713.       do 5112 i=1,5
  714.       if(dloc(i).eq.loc.and.dflag.ge.2)goto 5010
  715.  5112 continue
  716.  5120 if((liq(0).eq.k.and.here(bottle).eq.1).or.k.eq.liqloc(loc))
  717.      .  go to 5010
  718.       if(obj.ne.plant.or.at(plant2).eq.0.or.prop(plant2).eq.0)goto 5130
  719.       obj=plant2
  720.       goto 5010
  721.  5130 if(obj.ne.knife.or.knfloc.ne.loc)goto 5140
  722.       knfloc=-1
  723.       spk=116
  724.       goto 2011
  725.  5140 if(obj.ne.rod.or.here(rod2).eq.0)go to 5190
  726.       obj=rod2
  727.       goto 5010
  728.  5190 if((verb.eq.find.or.verb.eq.invent).and.wd2.eq.iz)goto 5010
  729.       call a5toa1(wd1,wd1x,' her','e.  ',tk,k)
  730.       write (*,5199) (tk(i),i=1,k)
  731.  5199 format(/' I see no ',20a1)
  732.       goto 2012
  733. c  figure out the new location
  734. c
  735. c  given the current location in "loc", and a motion verb number in "k", put
  736. c  the new location in "newloc".  the current loc is saved in "oldloc" in case
  737. c  he wants to retreat.  the current oldloc is saved in oldlc2, in case he
  738. c  dies.  (if he does, newloc will be limbo, and oldloc will be what killed
  739. c  him, so we need oldlc2, which is the last place he was safe.)
  740.  
  741.  8    kk=key(loc)
  742.       newloc=loc
  743.       if(kk.eq.0)call bug(26)
  744.       if(k.eq.null)goto 2
  745.       if(k.eq.back)goto 20
  746.       if(k.eq.look)goto 30
  747.       if(k.eq.cave)goto 40
  748.       oldlc2=oldloc
  749.       oldloc=loc
  750.  
  751.  9    ll=iabs(travel(kk))
  752.       if(mod(ll,1000).eq.1.or.mod(ll,1000).eq.k)goto 10
  753.       if(travel(kk).lt.0)goto 50
  754.       kk=kk+1
  755.       goto 9
  756.  
  757.  10   ll=ll/1000
  758.  11   newloc=ll/1000
  759.       k=mod(newloc,100)
  760.       if(newloc.le.300)goto 13
  761.       nl=newloc
  762.       if(prop(k).ne.((nl/100)-3)) go to 16
  763.  12   if(travel(kk).lt.0)call bug(25)
  764.       kk=kk+1
  765.       newloc=iabs(travel(kk))/1000
  766.       if(newloc.eq.ll)goto 12
  767.       ll=newloc
  768.       goto 11
  769.  
  770.  13   if(newloc.le.100)goto 14
  771.       nl=newloc
  772.       if(toting(k).eq.1.or.(nl.gt.200.and.at(k).eq.1))goto 16
  773.       goto 12
  774.  
  775.  14   nl=newloc
  776.       if(nl.ne.0.and.pct(nl).eq.0) go to 12
  777.  16   newloc=mod(ll,1000)
  778.       if(newloc.le.300)goto 2
  779.       if(newloc.le.500)goto 30000
  780.       nl=newloc
  781.       call rspeak(nl-500)
  782.       newloc=loc
  783.       goto 2
  784.  
  785. c  special motions come here.  labelling convention: statement numbers nnnxxc  (
  786.  
  787. 30000 newloc=newloc-300
  788.       if(newloc.gt.3)call bug(20)
  789.       goto (30100,30200,30300),newloc
  790.  
  791. c  travel 301.  plover-alcove passage.  can carry only emerald.  note: travel
  792. c  table must include "useless" entries going through passage, which can never
  793. c  be used for actual motion, but can be spotted by "go back".
  794.  
  795. 30100 newloc=99+100-loc
  796.       if(holdng.eq.0.or.(holdng.eq.1.and.toting(emrald).eq.1))goto 2
  797.       newloc=loc
  798.       call rspeak(117)
  799.       goto 2
  800.  
  801. c  travel302.  plover transport.  drop the emerald (only use special travel if
  802. c  toting it), so he's forced to use the plover-passage to get it out.  having
  803. c  dropped it, go back and pretend he wasn't carrying it after all.
  804.  
  805. 30200 call drop(emrald,loc)
  806.       goto 12
  807.  
  808. c  travel 303.  troll bridge.  must be done only as special motion so that
  809. c  dwarves won't wander across and encounter the bear.  (they won't follow the
  810. c  player there because that region is forbidden to the pirate.)  if
  811. c  prop(troll)=1, he's crossed since paying, so step out and block him.
  812. c  (standard travel entries check for prop(troll)=0.)  special stuff for bear.
  813.  
  814. 30300 if(prop(troll).ne.1)goto 30310
  815.       call pspeak(troll,1)
  816.       prop(troll)=0
  817.       call move(troll2,0)
  818.       call move(troll2+100,0)
  819.       call move(troll,plac(troll))
  820.       call move(troll+100,fixd(troll))
  821.       call juggle(chasm)
  822.       newloc=loc
  823.       goto 2
  824.  
  825. 30310 newloc=plac(troll)+fixd(troll)-loc
  826.       if(prop(troll).eq.0)prop(troll)=1
  827.       if(toting(bear).eq.0)goto 2
  828.       call rspeak(162)
  829.       prop(chasm)=1
  830.       prop(troll)=2
  831.       nl=newloc
  832.       call drop(bear,nl)
  833.       fixed(bear)=-1
  834.       prop(bear)=3
  835.       if(prop(spices).lt.0)tally2=tally2+1
  836.       oldlc2=newloc
  837.       goto 99
  838.  
  839. c  end of specials.
  840.  
  841. c  handle "go back".  look for verb which goes from loc to oldloc, or to oldlc2
  842. c  if oldloc has forced-motion.  k2 saves entry -> forced loc -> previous loc.
  843.  
  844.  20   k=oldloc
  845.       if(forced(k).eq.1)k=oldlc2
  846.       oldlc2=oldloc
  847.       oldloc=loc
  848.       k2=0
  849.       if(k.ne.loc)goto 21
  850.       call rspeak(91)
  851.       goto 2
  852.  
  853.  21   ll=mod((iabs(travel(kk))/1000),1000)
  854.       if(ll.eq.k)goto 25
  855.       if(ll.gt.300)goto 22
  856.       j=key(ll)
  857.       ls=ll
  858.       trv=mod((iabs(travel(j))/1000),1000)
  859.       if(forced(ls).eq.1.and.trv.eq.k)
  860.      .  k2=kk
  861.  22   if(travel(kk).lt.0)goto 23
  862.       kk=kk+1
  863.       goto 21
  864.  
  865.  23   kk=k2
  866.       if(kk.ne.0)goto 25
  867.       call rspeak(140)
  868.       goto 2
  869.  
  870.  25   k=mod(iabs(travel(kk)),1000)
  871.       kk=key(loc)
  872.       goto 9
  873.  
  874. c  look.  can't give more detail.  pretend it wasn't dark (though it may "now"
  875. c  be dark) so he won't fall into a pit while staring into the gloom.
  876.  
  877.  30   if(detail.lt.3)call rspeak(15)
  878.       detail=detail+1
  879.       wzdark=0
  880.       abb(loc)=0
  881.       goto 2
  882.  
  883. c  cave.  different messages depending on whether above ground.
  884.  
  885.  40   if(loc.lt.8)call rspeak(57)
  886.       if(loc.ge.8)call rspeak(58)
  887.       goto 2
  888.  
  889. c  non-applicable motion.  various messages depending on word given.
  890.  
  891.  50   spk=12
  892.       if(k.ge.43.and.k.le.50)spk=9
  893.       if(k.eq.29.or.k.eq.30)spk=9
  894.       if(k.eq.7.or.k.eq.36.or.k.eq.37)spk=10
  895.       if(k.eq.11.or.k.eq.19)spk=11
  896.       if(verb.eq.find.or.verb.eq.invent)spk=59
  897.       if(k.eq.62.or.k.eq.65)spk=42
  898.       if(k.eq.17)spk=80
  899.       call rspeak(spk)
  900.       goto 2
  901. c  "you're dead, jim."
  902. c
  903. c  if the current loc is zero, it means the clown got himself killed.  we'll
  904. c  allow this maxdie times.  maxdie is automatically set based on the number of
  905. c  snide messages available.  each death results in a message (81, 83, etc.)
  906. c  which offers reincarnation; if accepted, this results in message 82, 84,
  907. c  etc.  the last time, if he wants another chance, he gets a snide remark as
  908. c  we exit.  when reincarnated, all objects being carried get dropped at oldlc2
  909. c  (presumably the last place prior to being killed) without change of props.
  910. c  the loop runs backwards to assure that the bird is dropped before the cage.
  911. c  (this kluge could be changed once we're sure all references to bird and cage
  912. c  are done by keywords.)  the lamp is a special case (it wouldn't do to leave
  913. c  it in the cave).  it is turned off and left outside the building (only if he
  914. c  was carrying it, of course).  he himself is left inside the building (and
  915. c  heaven help him if he tries to xyzzy back into the cave without the lamp).
  916. c  oldloc is zapped so he can't just "retreat".
  917.  
  918. c  the easiest way to get killed is to fall into a pit in pitch darkness.
  919.  
  920.  90   call rspeak(23)
  921.       oldlc2=loc
  922.  
  923. c  okay, he's dead.  let's get on with it.
  924.  
  925.  99   if(closng.eq.1)goto 95
  926.       yea=yes(81+numdie*2,82+numdie*2,54)
  927.       numdie=numdie+1
  928.       if(numdie.eq.maxdie.or.yea.eq.0)goto 20000
  929.       place(water)=0
  930.       place(oil)=0
  931.       if(toting(lamp).eq.1)prop(lamp)=0
  932.       do 98 j=1,100
  933.       i=101-j
  934.       if(toting(i).eq.0)goto 98
  935.       k=oldlc2
  936.       if(i.eq.lamp)k=1
  937.       call drop(i,k)
  938.  98   continue
  939.       loc=3
  940.       oldloc=loc
  941.       goto 2000
  942.  
  943. c  he died during closing time.  no resurrection.  tally up a death and exit.
  944.  
  945.  95   call rspeak(131)
  946.       numdie=numdie+1
  947.       goto 20000
  948. c  routines for performing the various action verbs
  949.  
  950. c  statement numbers in this section are 8000 for intransitive verbs, 9000 for
  951. c  transitive, plus ten times the verb number.  many intransitive verbs use the
  952. c  transitive code, and some verbs use code for other verbs, as noted below.
  953.  
  954. c  random intransitive verbs come here.  clear obj just in case (see "attack").
  955.  
  956.  8000 call a5toa1(wd1,wd1x,' wha','t?  ',tk,k)
  957.       write (*,8002) (tk(i),i=1,k)
  958.  8002 format(/' ',20a1)
  959.       obj=0
  960.       goto 2600
  961.  
  962. c  carry, no object given yet.  ok if only one object present.
  963.  
  964.  8010 if(atloc(loc).eq.0.or.link(atloc(loc)).ne.0)goto 8000
  965.       do 8012 i=1,5
  966.       if(dloc(i).eq.loc.and.dflag.ge.2)goto 8000
  967.  8012 continue
  968.       obj=atloc(loc)
  969.  
  970. c  carry an object.  special cases for bird and cage (if bird in cage, can't
  971. c  take one without the other.  liquids also special, since they depend on
  972. c  status of bottle.  also various side effects, etc.
  973.  
  974.  9010 if(toting(obj).eq.1)goto 2011
  975.       spk=25
  976.       if(obj.eq.plant.and.prop(plant).le.0)spk=115
  977.       if(obj.eq.bear.and.prop(bear).eq.1)spk=169
  978.       if(obj.eq.chain.and.prop(bear).ne.0)spk=170
  979.       if(fixed(obj).ne.0)goto 2011
  980.       if(obj.ne.water.and.obj.ne.oil)goto 9017
  981.       if(here(bottle).eq.1.and.liq(0).eq.obj)goto 9018
  982.       obj=bottle
  983.       if(toting(bottle).eq.1.and.prop(bottle).eq.1)goto 9220
  984.       if(prop(bottle).ne.1)spk=105
  985.       if(toting(bottle).eq.0)spk=104
  986.       goto 2011
  987.  9018 obj=bottle
  988.  9017 if(holdng.lt.7)goto 9016
  989.       call rspeak(92)
  990.       goto 2012
  991.  9016 if(obj.ne.bird)goto 9014
  992.       if(prop(bird).ne.0)goto 9014
  993.       if(toting(rod).eq.0)goto 9013
  994.       call rspeak(26)
  995.       goto 2012
  996.  9013 if(toting(cage).eq.1)goto 9015
  997.       call rspeak(27)
  998.       goto 2012
  999.  9015 prop(bird)=1
  1000.  9014 if((obj.eq.bird.or.obj.eq.cage).and.prop(bird).ne.0)
  1001.      .   call carry(bird+cage-obj,loc)
  1002.       call carry(obj,loc)
  1003.       k=liq(0)
  1004.       if(obj.eq.bottle.and.k.ne.0)place(k)=-1
  1005.       goto 2009
  1006.  
  1007. c  discard object.  "throw" also comes here for most objects.  special cases for
  1008. c  bird (might attack snake or dragon) and cage (might contain bird) and vase.
  1009. c  drop coins at vending machine for extra batteries.
  1010.  
  1011.  9020 if(toting(rod2).eq.1.and.obj.eq.rod.and.toting(rod).eq.0)obj=rod2
  1012.       if(toting(obj).eq.0)goto 2011
  1013.       if(obj.ne.bird.or.here(snake).eq.0)goto 9024
  1014.       call rspeak(30)
  1015.       if(closed.eq.1)goto 19000
  1016.       call dstroy(snake)
  1017. c  set prop for use by travel options
  1018.       prop(snake)=1
  1019.  9021 k=liq(0)
  1020.       if(k.eq.obj)obj=bottle
  1021.       if(obj.eq.bottle.and.k.ne.0)place(k)=0
  1022.       if(obj.eq.cage.and.prop(bird).ne.0)call drop(bird,loc)
  1023.       if(obj.eq.bird)prop(bird)=0
  1024.       call drop(obj,loc)
  1025.       goto 2012
  1026.  
  1027.  9024 if(obj.ne.coins.or.here(vend).eq.0)goto 9025
  1028.       call dstroy(coins)
  1029.       call drop(batter,loc)
  1030.       call pspeak(batter,0)
  1031.       goto 2012
  1032.  
  1033.  9025 if(obj.ne.bird.or.at(dragon).eq.0.or.prop(dragon).ne.0)goto 9026
  1034.       call rspeak(154)
  1035.       call dstroy(bird)
  1036.       prop(bird)=0
  1037.       if(place(snake).eq.plac(snake))tally2=tally2+1
  1038.       goto 2012
  1039.  
  1040.  9026 if(obj.ne.bear.or.at(troll).eq.0)goto 9027
  1041.       call rspeak(163)
  1042.       call move(troll,0)
  1043.       call move(troll+100,0)
  1044.       call move(troll2,plac(troll))
  1045.       call move(troll2+100,fixd(troll))
  1046.       call juggle(chasm)
  1047.       prop(troll)=2
  1048.       goto 9021
  1049.  
  1050.  9027 if(obj.eq.vase.and.loc.ne.plac(pillow))goto 9028
  1051.       call rspeak(54)
  1052.       goto 9021
  1053.  
  1054.  9028 prop(vase)=2
  1055.       if(at(pillow).eq.1)prop(vase)=0
  1056.       call pspeak(vase,prop(vase)+1)
  1057.       if(prop(vase).ne.0)fixed(vase)=-1
  1058.       goto 9021
  1059.  
  1060. c  say.  echo wd2 (or wd1 if no wd2 (say what?, etc.).)  magic words override.
  1061.  
  1062.  9030 call a5toa1(wd2,wd2x,'".  ','    ',tk,k)
  1063.       if(wd2.eq.iz)call a5toa1(wd1,wd1x,'".  ','    ',tk,k)
  1064.       if(wd2.ne.iz)wd1=wd2
  1065.       i=vocab(wd1,-1)
  1066.       if(i.eq.62.or.i.eq.65.or.i.eq.71.or.i.eq.2025)goto 9035
  1067.       write (*,9032) (tk(i),i=1,k)
  1068.  9032 format(/' Okay, "',20a1)
  1069.       goto 2012
  1070.  
  1071.  9035 wd2=iz
  1072.       obj=0
  1073.       goto 2630
  1074.  
  1075. c  lock, unlock, no object given.  assume various things if present.
  1076.  
  1077.  8040 spk=28
  1078.       if(here(clam).eq.1)obj=clam
  1079.       if(here(oyster).eq.1)obj=oyster
  1080.       if(at(door).eq.1)obj=door
  1081.       if(at(grate).eq.1)obj=grate
  1082.       if(obj.ne.0.and.here(chain).eq.1)goto 8000
  1083.       if(here(chain).eq.1)obj=chain
  1084.       if(obj.eq.0)goto 2011
  1085.  
  1086. c  lock, unlock object.  special stuff for opening clam/oyster and for chain.
  1087.  
  1088.  9040 if(obj.eq.clam.or.obj.eq.oyster)goto 9046
  1089.       if(obj.eq.door)spk=111
  1090.       if(obj.eq.door.and.prop(door).eq.1)spk=54
  1091.       if(obj.eq.cage)spk=32
  1092.       if(obj.eq.keys)spk=55
  1093.       if(obj.eq.grate.or.obj.eq.chain)spk=31
  1094.       if(spk.ne.31.or.here(keys).eq.0)goto 2011
  1095.       if(obj.eq.chain)goto 9048
  1096.       if(closng.eq.0)goto 9043
  1097.       k=130
  1098.       if(panic.eq.0)clock2=15
  1099.       panic=1
  1100.       goto 2010
  1101.  
  1102.  9043 k=34+prop(grate)
  1103.       prop(grate)=1
  1104.       if(verb.eq.lock)prop(grate)=0
  1105.       k=k+2*prop(grate)
  1106.       goto 2010
  1107.  
  1108. c  clam/oyster.
  1109.  9046 k=0
  1110.       if(obj.eq.oyster)k=1
  1111.       spk=124+k
  1112.       if(toting(obj).eq.1)spk=120+k
  1113.       if(toting(tridnt).eq.0)spk=122+k
  1114.       if(verb.eq.lock)spk=61
  1115.       if(spk.ne.124)goto 2011
  1116.       call dstroy(clam)
  1117.       call drop(oyster,loc)
  1118.       call drop(pearl,105)
  1119.       goto 2011
  1120.  
  1121. c  chain.
  1122.  9048 if(verb.eq.lock)goto 9049
  1123.       spk=171
  1124.       if(prop(bear).eq.0)spk=41
  1125.       if(prop(chain).eq.0)spk=37
  1126.       if(spk.ne.171)goto 2011
  1127.       prop(chain)=0
  1128.       fixed(chain)=0
  1129.       if(prop(bear).ne.3)prop(bear)=2
  1130.       fixed(bear)=2-prop(bear)
  1131.       goto 2011
  1132.  
  1133.  9049 spk=172
  1134.       if(prop(chain).ne.0)spk=34
  1135.       if(loc.ne.plac(chain))spk=173
  1136.       if(spk.ne.172)goto 2011
  1137.       prop(chain)=2
  1138.       if(toting(chain).eq.1)call drop(chain,loc)
  1139.       fixed(chain)=-1
  1140.       goto 2011
  1141.  
  1142. c  light lamp
  1143.  
  1144.  9070 if(here(lamp).eq.0)goto 2011
  1145.       spk=184
  1146.       if(limit.lt.0)goto 2011
  1147.       prop(lamp)=1
  1148.       call rspeak(39)
  1149.       if(wzdark.eq.1)goto 2000
  1150.       goto 2012
  1151.  
  1152. c  lamp off
  1153.  
  1154.  9080 if(here(lamp).eq.0)goto 2011
  1155.       prop(lamp)=0
  1156.       call rspeak(40)
  1157.       if(dark(0).eq.1)call rspeak(16)
  1158.       goto 2012
  1159.  
  1160. c  wave.  no effect unless waving rod at fissure.
  1161.  
  1162.  9090 if((toting(obj)).eq.0.and.(obj.ne.rod.or.toting(rod2).eq.0))
  1163.      .   spk=29
  1164.       if(obj.ne.rod.or.at(fissur).eq.0.or.toting(obj).eq.0
  1165.      .   .or.closng.eq.1)go to 2011
  1166.       prop(fissur)=1-prop(fissur)
  1167.       call pspeak(fissur,2-prop(fissur))
  1168.       goto 2012
  1169.  
  1170. c  attack.  assume target if unambiguous.  "throw" also links here.  attackable
  1171. c  objects fall into two categories: enemies (snake, dwarf, etc.)  and others
  1172. c  (bird, clam).  ambiguous if two enemies, or if no enemies but two others.
  1173.  
  1174.  9120 do 9121 i=1,5
  1175.       if(dloc(i).eq.loc.and.dflag.ge.2)goto 9122
  1176.  9121 continue
  1177.       i=0
  1178.  9122 if(obj.ne.0)goto 9124
  1179.       if(i.ne.0)obj=dwarf
  1180.       if(here(snake).eq.1)obj=obj*100+snake
  1181.       if(at(dragon).eq.1.and.prop(dragon).eq.0)obj=obj*100+dragon
  1182.       if(at(troll).eq.1)obj=obj*100+troll
  1183.       if(here(bear).eq.1.and.prop(bear).eq.0)obj=obj*100+bear
  1184.       if(obj.gt.100)goto 8000
  1185.       if(obj.ne.0)goto 9124
  1186. c  can't attack bird by throwing axe.
  1187.       if(here(bird).eq.1.and.verb.ne.throw)obj=bird
  1188. c  clam and oyster both treated as clam for intransitive case; no harm done.
  1189.       if(here(clam).eq.1.or.here(oyster).eq.1)obj=100*obj+clam
  1190.       if(obj.gt.100)goto 8000
  1191.  9124 if(obj.ne.bird)goto 9125
  1192.       spk=137
  1193.       if(closed.eq.1)goto 2011
  1194.       call dstroy(bird)
  1195.       prop(bird)=0
  1196.       if(place(snake).eq.plac(snake))tally2=tally2+1
  1197.       spk=45
  1198.  9125 if(obj.eq.0)spk=44
  1199.       if(obj.eq.clam.or.obj.eq.oyster)spk=150
  1200.       if(obj.eq.snake)spk=46
  1201.       if(obj.eq.dwarf)spk=49
  1202.       if(obj.eq.dwarf.and.closed.eq.1)goto 19000
  1203.       if(obj.eq.dragon)spk=167
  1204.       if(obj.eq.troll)spk=157
  1205.       if(obj.eq.bear)spk=165+(prop(bear)+1)/2
  1206.       if(obj.ne.dragon.or.prop(dragon).ne.0)goto 2011
  1207. c  fun stuff for dragon.  if he insists on attacking it, win!  set prop to dead,
  1208. c  move dragon to central loc (still fixed), move rug there (not fixed), and
  1209. c  move him there, too.  then do a null motion to get new description.
  1210.       call rspeak(49)
  1211.       verb=0
  1212.       obj=0
  1213.       call getin(wd1,wd1x,wd2,wd2x)
  1214.       if(wd1.ne.'y   '.and.wd1.ne.'yes ')goto 2608
  1215.       call pspeak(dragon,1)
  1216.       prop(dragon)=2
  1217.       prop(rug)=0
  1218.       k=(plac(dragon)+fixd(dragon))/2
  1219.       call move(dragon+100,-1)
  1220.       call move(rug+100,0)
  1221.       call move(dragon,k)
  1222.       call move(rug,k)
  1223.       do 9126 obj=1,100
  1224.       idondx=obj
  1225.       if(place(idondx).eq.plac(dragon).or.
  1226.      .   place(idondx).eq.fixd(dragon))
  1227.      .   call move(idondx,k)
  1228.  9126 continue
  1229.       loc=k
  1230.       k=null
  1231.       goto 8
  1232.  
  1233. c  pour.  if no object, or object is bottle, assume contents of bottle.
  1234. c  special tests for pouring water or oil on plant or rusty door.
  1235.  
  1236.  9130 if(obj.eq.bottle.or.obj.eq.0)obj=liq(0)
  1237.       if(obj.eq.0)goto 8000
  1238.       if(toting(obj).eq.0)goto 2011
  1239.       spk=78
  1240.       if(obj.ne.oil.and.obj.ne.water)goto 2011
  1241.       prop(bottle)=1
  1242.       place(obj)=0
  1243.       spk=77
  1244.       if(at(plant).eq.0.and.at(door).eq.0) go to 2011
  1245.  
  1246.       if(at(door).eq.1)goto 9132
  1247.       spk=112
  1248.       if(obj.ne.water)goto 2011
  1249.       call pspeak(plant,prop(plant)+1)
  1250.       prop(plant)=mod(prop(plant)+2,6)
  1251.       prop(plant2)=prop(plant)/2
  1252.       k=null
  1253.       goto 8
  1254.  
  1255.  9132 prop(door)=0
  1256.       if(obj.eq.oil)prop(door)=1
  1257.       spk=113+prop(door)
  1258.       goto 2011
  1259.  
  1260. c  eat.  intransitive: assume food if present, else ask what.  transitive: food
  1261. c  ok, some things lose appetite, rest are ridiculous.
  1262.  
  1263.  8140 if(here(food).eq.0)goto 8000
  1264.  8142 call dstroy(food)
  1265.       spk=72
  1266.       goto 2011
  1267.  9140 if(obj.eq.food)goto 8142
  1268.       if(obj.eq.bird.or.obj.eq.snake.or.obj.eq.clam.or.obj.eq.oyster
  1269.      .   .or.obj.eq.dwarf.or.obj.eq.dragon.or.obj.eq.troll
  1270.      .   .or.obj.eq.bear)spk=71
  1271.       goto 2011
  1272.  
  1273. c  drink.  if no object, assume water and look for it here.  if water is in
  1274. c  the bottle, drink that, else must be at a water loc, so drink stream.
  1275.  
  1276.  9150 if(obj.eq.0.and.liqloc(loc).ne.water.and.(liq(0).ne.water
  1277.      .   .or.here(bottle).eq.0))goto 8000
  1278.       if(obj.ne.0.and.obj.ne.water)spk=110
  1279.       if(spk.eq.110.or.liq(0).ne.water.or.here(bottle).eq.0)goto 2011
  1280.       prop(bottle)=1
  1281.       place(water)=0
  1282.       spk=74
  1283.       goto 2011
  1284.  
  1285. c  rub.  yields various snide remarks.
  1286.  
  1287.  9160 if(obj.ne.lamp)spk=76
  1288.       goto 2011
  1289.  
  1290. c  throw.  same as discard unless axe.  then same as attack except ignore bird,
  1291. c  and if dwarf is present then one might be killed.  (only way to do so)
  1292. c  axe also special for dragon, bear, and troll.  treasures special for troll.
  1293.  
  1294.  9170 if(toting(rod2).eq.1.and.obj.eq.rod.and.toting(rod).eq.0)obj=rod2
  1295.       if(toting(obj).eq.0)goto 2011
  1296.       if(obj.ge.50.and.obj.le.maxtrs.and.at(troll).eq.1)goto 9178
  1297.       if(obj.eq.food.and.here(bear).eq.1)goto 9177
  1298.       if(obj.ne.axe)goto 9020
  1299.       do 9171 i=1,5
  1300. c  needn't check dflag if axe is here.
  1301.       if(dloc(i).eq.loc)goto 9172
  1302.  9171 continue
  1303.       spk=152
  1304.       if(at(dragon).eq.1.and.prop(dragon).eq.0)goto 9175
  1305.       spk=158
  1306.       if(at(troll).eq.1)goto 9175
  1307.       if(here(bear).eq.1.and.prop(bear).eq.0)goto 9176
  1308.       obj=0
  1309.       goto 9120
  1310.  
  1311.  9172 spk=48
  1312.       if(ran(3).eq.0) go to 9175
  1313.       dseen(i)=0
  1314.       dloc(i)=0
  1315.       spk=47
  1316.       dkill=dkill+1
  1317.       if(dkill.eq.1)spk=149
  1318.  9175 call rspeak(spk)
  1319.       call drop(axe,loc)
  1320.       k=null
  1321.       goto 8
  1322.  
  1323. c  this'll teach him to throw the axe at the bear!
  1324.  9176 spk=164
  1325.       call drop(axe,loc)
  1326.       fixed(axe)=-1
  1327.       prop(axe)=1
  1328.       call juggle(bear)
  1329.       goto 2011
  1330.  
  1331. c  but throwing food is another story.
  1332.  9177 obj=bear
  1333.       goto 9210
  1334.  
  1335.  9178 spk=159
  1336. c  snarf a treasure for the troll.
  1337.       call drop(obj,0)
  1338.       call move(troll,0)
  1339.       call move(troll+100,0)
  1340.       call drop(troll2,plac(troll))
  1341.       call drop(troll2+100,fixd(troll))
  1342.       call juggle(chasm)
  1343.       goto 2011
  1344.  
  1345. c  quit.  intransitive only.  verify intent and exit if that's what he wants.
  1346.  
  1347.  8180 gaveup=yes(22,54,54)
  1348.  8185 if(gaveup.eq.1)goto 20000
  1349.       goto 2012
  1350.  
  1351. c  find.  might be carrying it, or it might be here.  else give caveat.
  1352.  
  1353.  9190 if(at(obj).eq.1.or.(liq(0).eq.obj.and.at(bottle).eq.1)
  1354.      .   .or.k.eq.liqloc(loc))spk=94
  1355.       do 9192 i=1,5
  1356.  9192 if(dloc(i).eq.loc.and.dflag.ge.2.and.obj.eq.dwarf)spk=94
  1357.       if(closed.eq.1)spk=138
  1358.       if(toting(obj).eq.1)spk=24
  1359.       goto 2011
  1360.  
  1361. c  inventory.  if object, treat same as find.  else report on current burden.
  1362.  
  1363.  8200 spk=98
  1364.       blklin=1
  1365.       do 8201 i=1,100
  1366.       idondx=i
  1367.       if(idondx.eq.bear.or.toting(idondx).eq.0)goto 8201
  1368.       if(spk.eq.98)call rspeak(99)
  1369.       call pspeak(idondx,-1)
  1370.       if (blklin.eq.1) blklin=0
  1371.       spk=0
  1372.  8201 continue
  1373.       blklin=1
  1374.       if(toting(bear).eq.1)spk=141
  1375.       goto 2011
  1376.  
  1377. c  feed.  if bird, no seed.  snake, dragon, troll: quip.  if dwarf, make him
  1378. c  mad.  bear, special.
  1379.  
  1380.  9210 if(obj.ne.bird)goto 9212
  1381.       spk=100
  1382.       goto 2011
  1383.  
  1384.  9212 if(obj.ne.snake.and.obj.ne.dragon.and.obj.ne.troll)goto 9213
  1385.       spk=102
  1386.       if(obj.eq.dragon.and.prop(dragon).ne.0)spk=110
  1387.       if(obj.eq.troll)spk=182
  1388.       if(obj.ne.snake.or.closed.eq.1.or.here(bird).eq.0)goto 2011
  1389.       spk=101
  1390.       call dstroy(bird)
  1391.       prop(bird)=0
  1392.       tally2=tally2+1
  1393.       goto 2011
  1394.  
  1395.  9213 if(obj.ne.dwarf)goto 9214
  1396.       if(here(food).eq.0)goto 2011
  1397.       spk=103
  1398.       dflag=dflag+1
  1399.       goto 2011
  1400.  
  1401.  9214 if(obj.ne.bear)goto 9215
  1402.       if(prop(bear).eq.0)spk=102
  1403.       if(prop(bear).eq.3)spk=110
  1404.       if(here(food).eq.0)goto 2011
  1405.       call dstroy(food)
  1406.       prop(bear)=1
  1407.       fixed(axe)=0
  1408.       prop(axe)=0
  1409.       spk=168
  1410.       goto 2011
  1411.  
  1412.  9215 spk=14
  1413.       goto 2011
  1414.  
  1415. c  fill.  bottle must be empty, and some liquid available.  (vase is nasty.)
  1416.  
  1417.  9220 if(obj.eq.vase)goto 9222
  1418.       if(obj.ne.0.and.obj.ne.bottle)goto 2011
  1419.       if(obj.eq.0.and.here(bottle).eq.0)goto 8000
  1420.       spk=107
  1421.       if(liqloc(loc).eq.0)spk=106
  1422.       if(liq(0).ne.0)spk=105
  1423.       if(spk.ne.107)goto 2011
  1424.       prop(bottle)=mod(cond(loc),4)/2*2
  1425.       k=liq(0)
  1426.       if(toting(bottle).eq.1)place(k)=-1
  1427.       if(k.eq.oil)spk=108
  1428.       goto 2011
  1429.  
  1430.  9222 spk=29
  1431.       if(liqloc(loc).eq.0)spk=144
  1432.       if(liqloc(loc).eq.0.or.toting(vase).eq.0)goto 2011
  1433.       call rspeak(145)
  1434.       prop(vase)=2
  1435.       fixed(vase)=-1
  1436.       goto 9024
  1437.  
  1438. c  blast.  no effect unless you've got dynamite, which is a neat trick!
  1439.  
  1440.  9230 if(prop(rod2).lt.0.or.closed.eq.0)goto 2011
  1441.       bonus=133
  1442.       if(loc.eq.115)bonus=134
  1443.       if(here(rod2).eq.1)bonus=135
  1444.       call rspeak(bonus)
  1445.       goto 20000
  1446.  
  1447. c  score.  go to scoring section, which will return to 8241 if scorng is true.
  1448.  
  1449.  8240 scorng=1
  1450.       goto 20000
  1451.  
  1452.  8241 scorng=0
  1453.       write(*,8243) score, mxscor, turns
  1454.  8243 format(/' If you were to quit now,',/,' You would score',i4
  1455.      . ,' out of a possible',i4,', using ',i5,' turns.')
  1456. c  gaveup=yes(143,54,54)
  1457. c  goto 8185
  1458.       go to 2012
  1459. c  fee fie foe foo (and fum).  advance to next state if given in proper order.
  1460. c  look up wd1 in section 3 of vocab to determine which word we've got.  last
  1461. c  word zips the eggs back to the giant room (unless already there).
  1462.  
  1463.  8250 k=vocab(wd1,3)
  1464.       spk=42
  1465.       if(foobar.eq.1-k)goto 8252
  1466.       if(foobar.ne.0)spk=151
  1467.       goto 2011
  1468.  
  1469.  8252 foobar=k
  1470.       if(k.ne.4)goto 2009
  1471.       foobar=0
  1472.       if(place(eggs).eq.plac(eggs)
  1473.      .      .or.(toting(eggs).eq.1.and.loc.eq.plac(eggs)))goto 2011
  1474. c  bring back troll if we steal the eggs back from him before crossing.
  1475.       if(place(eggs).eq.0.and.place(troll).eq.0.and.prop(troll).eq.0)
  1476.      .      prop(troll)=1
  1477.       k=2
  1478.       if(here(eggs).eq.1)k=1
  1479.       if(loc.eq.plac(eggs))k=0
  1480.       call move(eggs,plac(eggs))
  1481.       call pspeak(eggs,k)
  1482.       goto 2012
  1483.  
  1484. c  brief.  intransitive only.  suppress long descriptions after first time.
  1485.  
  1486.  8260 spk=156
  1487.       abbnum=10000
  1488.       detail=3
  1489.       goto 2011
  1490.  
  1491. c  read.  magazines in dwarvish, message we've seen, and . . . oyster?
  1492.  
  1493.  8270 if(here(magzin).eq.1)obj=magzin
  1494.       if(here(tablet).eq.1)obj=obj*100+tablet
  1495.       if(here(messag).eq.1)obj=obj*100+messag
  1496.       if(closed.eq.1.and.toting(oyster).eq.1)obj=oyster
  1497.       if(obj.gt.100.or.obj.eq.0.or.dark(0).eq.1)goto 8000
  1498.  
  1499.  9270 if(dark(0).eq.1)goto 5190
  1500.       if(obj.eq.magzin)spk=190
  1501.       if(obj.eq.tablet)spk=196
  1502.       if(obj.eq.messag)spk=191
  1503.       if(obj.eq.oyster.and.hinted(2).eq.1.and.toting(oyster).eq.1)
  1504.      .  spk=194
  1505.       if(obj.ne.oyster.or.hinted(2).eq.1.or.toting(oyster).eq.0
  1506.      .   .or.closed.eq.0)goto 2011
  1507.       hinted(2)=yes(192,193,54)
  1508.       goto 2012
  1509.  
  1510. c  break.  only works for mirror in repository and, of course, the vase.
  1511.  
  1512.  9280 if(obj.eq.mirror)spk=148
  1513.       if(obj.eq.vase.and.prop(vase).eq.0)goto 9282
  1514.       if(obj.ne.mirror.or.closed.eq.0)goto 2011
  1515.       call rspeak(197)
  1516.       goto 19000
  1517.  
  1518.  9282 spk=198
  1519.       if(toting(vase).eq.1)call drop(vase,loc)
  1520.       prop(vase)=2
  1521.       fixed(vase)=-1
  1522.       goto 2011
  1523.  
  1524. c  wake.  only use is to disturb the dwarves.
  1525.  
  1526.  9290 if(obj.ne.dwarf.or.closed.eq.0)goto 2011
  1527.       call rspeak(199)
  1528.       goto 19000
  1529. c
  1530. c  suspend.  offer to exit and give specs on restart.
  1531. c  upon restarting, "resume" on first turn only comes to 8305
  1532. c
  1533.  8300 write (*,8302)
  1534.  8302 format(/' I can suspend your Adventure for you so that you can',
  1535.      . /,' restart later, but you will have to type "resume" on your',
  1536.      . /,' FIRST TURN.  The save process will write a 2772 byte file',
  1537.      . /,' named ADVENTUR.SV in your current directory.')
  1538. c
  1539.       if(yes(200,54,54).eq.0) go to 2012
  1540. c
  1541. c  write data file with all the good stuff to resume from
  1542. c
  1543.       open (2,file='adventur.sv',form='unformatted',status='unknown')
  1544.       write (2) place,prop,link,abb,cond,atloc,fixd,plac,hinted,
  1545.      .   hintlc,dseen,dloc,odloc,fixed,hints,tally,tally2,dflag,turns,
  1546.      .   limit,iwest,knfloc,detail,abbnum,maxdie,numdie,holdng,dkill,
  1547.      .   foobar,bonus,lmwarn,clock1,clock2,panic,closed,obj,verb,newloc
  1548.      .  ,loc,dtotal,attack,stick,itk,idondx,kk,oldlc2,oldloc,wzdark,
  1549.      .  closng
  1550.       close (2)
  1551. c
  1552.       write (*,83001)
  1553. 83001 format(//,' Your Adventure has been saved.  Type "resume"',/,
  1554.      .   ' on your FIRST TURN to restart where you left off.',//)
  1555.       go to 25000
  1556. c
  1557. c  resume saved game from data file adventur.sv.  resume must be on
  1558. c  first turn.  comes here to read all variables as we wrote them
  1559. c  and proceeds.
  1560. c
  1561. 8305  open (2,file='adventur.sv',form='unformatted')
  1562.       read  (2) place,prop,link,abb,cond,atloc,fixd,plac,hinted,
  1563.      .   hintlc,dseen,dloc,odloc,fixed,hints,tally,tally2,dflag,turns,
  1564.      .   limit,iwest,knfloc,detail,abbnum,maxdie,numdie,holdng,dkill,
  1565.      .   foobar,bonus,lmwarn,clock1,clock2,panic,closed,obj,verb,newloc
  1566.      .  ,loc,dtotal,attack,stick,itk,idondx,kk,oldlc2,oldloc,wzdark,
  1567.      .  closng
  1568.       close (2)
  1569.       yea=1
  1570.       k=null
  1571.       goto 8
  1572.  
  1573. c  hours.  report current non-prime-time hours.
  1574.  
  1575.  8310 write (*,83101)
  1576. 83101 format (/,' Colossal Cave is always open.')
  1577.       goto 2012
  1578. c
  1579. c  hints
  1580.  
  1581. c  come here if he's been long enough at required loc(s) for some unused hint.
  1582. c  hint number is in variable "hint".  branch to quick test for additional
  1583. c  conditions, then come back to do neat stuff.  goto 40010 if conditions are
  1584. c  met and we want to offer the hint.  goto 40020 to clear hintlc back to zero,
  1585. c  40030 to take no action yet.
  1586.  
  1587. 40000 if(hint.lt.4.or.hint.gt.9) call bug(27)
  1588.       go to (40400,40500,40600,40700,40800,40900),(hint-3)
  1589. c     cave  bird  snake maze  dark  witt
  1590.  
  1591. 40010       hintlc(hint)=0
  1592.       if(yes(hints(hint,3),0,54).eq.0)goto 26021
  1593.       write (*,40012) hints (hint,2)
  1594. 40012 format(/' I am prepared to give you a hint, but it will cost you',
  1595.      . i2,' points.')
  1596.       hinted(hint)=yes(175,hints(hint,4),54)
  1597.       if(hinted(hint).eq.1.and.limit.gt.30)limit=limit+30*hints(hint,2)
  1598. 40020 hintlc(hint)=0
  1599. 40030 goto 26021
  1600.  
  1601. c  now for the quick tests.  see database description for one-line notes.
  1602.  
  1603. 40400 if(prop(grate).eq.0.and.here(keys).eq.0)goto 40010
  1604.       goto 40020
  1605.  
  1606. 40500 if(here(bird).eq.1.and.toting(rod).eq.1.and.obj.eq.bird)goto40010
  1607.       goto 40030
  1608.  
  1609. 40600 if(here(snake).eq.1.and.here(bird).eq.0)goto 40010
  1610.       goto 40020
  1611.  
  1612. 40700 if(atloc(loc).eq.0.and.atloc(oldloc).eq.0
  1613.      .   .and.atloc(oldlc2).eq.0.and.holdng.gt.1)goto 40010
  1614.       goto 40020
  1615.  
  1616. 40800 if(prop(emrald).ne.-1.and.prop(pyram).eq.-1)goto 40010
  1617.       goto 40020
  1618.  
  1619. 40900 goto 40010
  1620.  
  1621. c  cave closing and scoring
  1622.  
  1623. c  these sections handle the closing of the cave.  the cave closes "clock1"
  1624. c  turns after the last treasure has been located (including the pirate's
  1625. c  chest, which may of course never show up).  note that the treasures need not
  1626. c  have been taken yet, just located.  hence clock1 must be large enough to get
  1627. c  out of the cave (it only ticks while inside the cave).  when it hits zero,
  1628. c  we branch to 10000 to start closing the cave, and then sit back and wait for
  1629. c  him to try to get out.  if he doesn't within clock2 turns, we close the
  1630. c  cave; if he does try, we assume he panics, and give him a few additional
  1631. c  turns to get frantic before we close.  when clock2 hits zero, we branch to
  1632. c  11000 to transport him into the final puzzle.  note that the puzzle depends
  1633. c  upon all sorts of random things.  for instance, there must be no water or
  1634. c  oil, since there are beanstalks which we don't want to be able to water,
  1635. c  since the code can't handle it.  also, we can have no keys, since there is a
  1636. c  grate (having moved the fixed object!) there separating him from all the
  1637. c  treasures.  most of these problems arise from the use of negative prop
  1638. c  numbers to suppress the object descriptions until he's actually moved the
  1639. c  objects.
  1640.  
  1641. c  when the first warning comes, we lock the grate, destroy the bridge, kill
  1642. c  all the dwarves (and the pirate), remove the troll and bear (unless dead),
  1643. c  and set "closng" to true.  leave the dragon; too much trouble to move it.
  1644. c  from now until clock2 runs out, he cannot unlock the grate, move to any
  1645. c  location outside the cave (loc<9), or create the bridge.  nor can he be
  1646. c  resurrected if he dies.  note that the snake is already gone, since he got
  1647. c  to the treasure accessible only via the hall of the mt. king.  also, he's
  1648. c  been in giant room (to get eggs), so we can refer to it.  also also, he's
  1649. c  gotten the pearl, so we know the bivalve is an oyster.  *and*, the dwarves
  1650. c  must have been activated, since we've found chest.
  1651.  
  1652. 10000 prop(grate)=0
  1653.       prop(fissur)=0
  1654.       do 10010 i=1,6
  1655.       dseen(i)=0
  1656. 10010 dloc(i)=0
  1657.       call move(troll,0)
  1658.       call move(troll+100,0)
  1659.       call move(troll2,plac(troll))
  1660.       call move(troll2+100,fixd(troll))
  1661.       call juggle(chasm)
  1662.       if(prop(bear).ne.3)call dstroy(bear)
  1663.       prop(chain)=0
  1664.       fixed(chain)=0
  1665.       prop(axe)=0
  1666.       fixed(axe)=0
  1667.       call rspeak(129)
  1668.       clock1=-1
  1669.       closng=1
  1670.       goto 19999
  1671.  
  1672. c  once he's panicked, and clock2 has run out, we come here to set up the
  1673. c  storage room.  the room has two locs, hardwired as 115 (ne) and 116 (sw).
  1674. c  at the ne end, we place empty bottles, a nursery of plants, a bed of
  1675. c  oysters, a pile of lamps, rods with stars, sleeping dwarves, and him.  and
  1676. c  the sw end we place grate over treasures, snake pit, covey of caged birds,
  1677. c  more rods, and pillows.  a mirror stretches across one wall.  many of the
  1678. c  objects come from known locations and/or states (e.g. the snake is known to
  1679. c  have been destroyed and needn't be carried away from its old "place"),
  1680. c  making the various objects be handled differently.  we also drop all other
  1681. c  objects he might be carrying (lest he have some which could cause trouble,
  1682. c  such as the keys).  we describe the flash of light and trundle back.
  1683.  
  1684. 11000 prop(bottle)=put(bottle,115,1)
  1685.       prop(plant)=put(plant,115,0)
  1686.       prop(oyster)=put(oyster,115,0)
  1687.       prop(lamp)=put(lamp,115,0)
  1688.       prop(rod)=put(rod,115,0)
  1689.       prop(dwarf)=put(dwarf,115,0)
  1690.       loc=115
  1691.       oldloc=115
  1692.       newloc=115
  1693.  
  1694. c  leave the grate with normal (non-negative property).
  1695.  
  1696.       foo=put(grate,116,0)
  1697.       prop(snake)=put(snake,116,1)
  1698.       prop(bird)=put(bird,116,1)
  1699.       prop(cage)=put(cage,116,0)
  1700.       prop(rod2)=put(rod2,116,0)
  1701.       prop(pillow)=put(pillow,116,0)
  1702.  
  1703.       prop(mirror)=put(mirror,115,0)
  1704.       fixed(mirror)=116
  1705.  
  1706.       do 11010 i=1,100
  1707.       idondx=i
  1708. 11010 if(toting(idondx).eq.1)call dstroy(idondx)
  1709.  
  1710.       call rspeak(132)
  1711.       closed=1
  1712.       goto 2
  1713.  
  1714. c  another way we can force an end to things is by having the lamp give out.
  1715. c  when it gets close, we come here to warn him.  we go to 12000 if the lamp
  1716. c  and fresh batteries are here, in which case we replace the batteries and
  1717. c  continue. 12200 is for other cases of lamp dying.  12400 is when it goes
  1718. c  out, and 12600 is if he's wandered outside and the lamp is used up, in which
  1719. c  case we force him to give up.
  1720.  
  1721. 12000 call rspeak(188)
  1722.       prop(batter)=1
  1723.       if(toting(batter).eq.1)call drop(batter,loc)
  1724.       limit=limit+2500
  1725.       lmwarn=0
  1726.       goto 19999
  1727.  
  1728. 12200 if(lmwarn.eq.1.or.here(lamp).eq.0)goto 19999
  1729.       lmwarn=1
  1730.       spk=187
  1731.       if(place(batter).eq.0)spk=183
  1732.       if(prop(batter).eq.1)spk=189
  1733.       call rspeak(spk)
  1734.       goto 19999
  1735.  
  1736. 12400 limit=-1
  1737.       prop(lamp)=0
  1738.       if(here(lamp).eq.1)call rspeak(184)
  1739.       goto 19999
  1740.  
  1741. 12600 call rspeak(185)
  1742.       gaveup=1
  1743.       goto 20000
  1744.  
  1745. c  oh dear, he's disturbed the dwarves.
  1746.  
  1747. 19000 call rspeak(136)
  1748.  
  1749. c  exit code.  will eventually include scoring.  for now, however, ...
  1750.  
  1751. c  the present scoring algorithm is as follows:
  1752. c  objective:          points:        present total possible:
  1753. c  getting well into cave   45                    45
  1754. c  each treasure < chest    12                    60
  1755. c  treasure chest itself    14                    14
  1756. c  each treasure > chest    16                   144
  1757. c  surviving             (max-num)*10             30
  1758. c  not quitting              4                     4
  1759. c  reaching "closng"        25                    25
  1760. c  "closed": quit/killed    10
  1761. c            klutzed        25
  1762. c            wrong way      30
  1763. c            success        45                    45
  1764. c  came to witt's end        1                     1
  1765. c  round out the total       2                     2
  1766. c                                       total:   370
  1767. c  (points can also be deducted for using hints.)
  1768.  
  1769. 20000 score=0
  1770.       mxscor=0
  1771.  
  1772. c  first tally up the treasures.  must be in building and not broken.
  1773. c  give the poor guy 2 points just for finding each treasure.
  1774.  
  1775.       do 20010 i=50,maxtrs
  1776.       if(ptext(i).eq.0)goto 20010
  1777.       k=12
  1778.       if(i.eq.chest)k=14
  1779.       if(i.gt.chest)k=16
  1780.       if(prop(i).ge.0)score=score+2
  1781.       if(place(i).eq.3.and.prop(i).eq.0)score=score+k-2
  1782.       mxscor=mxscor+k
  1783. 20010 continue
  1784.  
  1785. c  now look at how he finished and how far he got.  maxdie and numdie tell us
  1786. c  how well he survived.  gaveup says whether he exited via quit.  dflag will
  1787. c  tell us if he ever got suitably deep into the cave.  closng still indicates
  1788. c  whether he reached the endgame.  and if he got as far as "cave closed"
  1789. c  (indicated by "closed"), then bonus is zero for mundane exits or 133, 134,
  1790. c  135 if he blew it (so to speak).
  1791.  
  1792.       score=score+(maxdie-numdie)*10
  1793.       mxscor=mxscor+maxdie*10
  1794.       if(scorng.eq.0.and.gaveup.eq.0)score=score+4
  1795.       mxscor=mxscor+4
  1796.       if(dflag.ne.0)score=score+45
  1797.       mxscor=mxscor+45
  1798.       if(closng.eq.1)score=score+25
  1799.       mxscor=mxscor+25
  1800.       if(closed.eq.0)go to 20020
  1801.       if(bonus.eq.0)score=score+10
  1802.       if(bonus.eq.135)score=score+25
  1803.       if(bonus.eq.134)score=score+30
  1804.       if(bonus.eq.133)score=score+45
  1805. 20020 mxscor=mxscor+45
  1806.  
  1807. c  did he come to witt's end as he should?
  1808.  
  1809.       if(place(magzin).eq.108)score=score+1
  1810.       mxscor=mxscor+1
  1811.  
  1812. c  round it off.
  1813.  
  1814.       score=score+2
  1815.       mxscor=mxscor+2
  1816.  
  1817. c  deduct points for hints.  hints < 4 are special; see database description.
  1818.  
  1819.       do 20030 i=1,hntmax
  1820. 20030 if(hinted(i).eq.1)score=score-hints(i,2)
  1821.  
  1822. c  return to score command if that's where we came from.
  1823.  
  1824.       if(scorng.eq.1)goto 8241
  1825.  
  1826. c  that should be good enough.  let's tell him all about it.
  1827.  
  1828.       write (*,20100) score, mxscor, turns
  1829. 20100 format(///' You scored',i4,' out of a possible',i4,
  1830.      . ', using',i5,' turns.')
  1831.  
  1832.       do 20200 i=1,clsses
  1833.       if(cval(i).ge.score)goto 20210
  1834. 20200 continue
  1835.       write (*,20202)
  1836. 20202 format(/' You just went off my scale !! (Whoops) !!'/)
  1837.       goto 25000
  1838.  
  1839. 20210 call speak(ctext(i))
  1840.       if(i.eq.clsses-1)goto 20220
  1841.       k=cval(i)+1-score
  1842.       iz='s.  '
  1843.       if(k.eq.1)iz='.   '
  1844.       write (*,20212) k, iz
  1845. 20212 format(/' To achieve the next higher rating, you need',i3,
  1846.      . ' more point',a2/)
  1847.       goto 25000
  1848.  
  1849. 20220 write (*,20222)
  1850. 20222 format(/' To achieve the next higher rating ',
  1851.      . 'would be a neat trick, Oh Great One!!'//' Congratulations!!'/)
  1852.  
  1853. 25000 write (*,25001)
  1854. 25001 format (/////)
  1855.       pause 'Please Press the ENTER Key to Exit From Adventure.'
  1856.       end
  1857. c
  1858. c  subroutines and functions
  1859.       subroutine speak(n)
  1860. c  print the message which starts at lines(n).  precede it with a blank line
  1861. c  unless blklin is false.
  1862.       implicit integer*2 (a-z)
  1863.       common /lincom/ lines
  1864.       common /txtcom/ rtext
  1865.       common /blkcom/ blklin
  1866.       dimension rtext (205)
  1867.       character*2 lines (21150)
  1868.       character*2 np,clines
  1869.       integer*4 nnn,k,l,i
  1870.       equivalence (clines,ilines)
  1871.       data np/'>$'/
  1872.       nnn=n
  1873.       if(nnn.eq.0)return
  1874.       if(lines(nnn+1).eq.np)return
  1875.       if(blklin.eq.1) write (*,2)
  1876.       k=nnn
  1877.  1    clines=lines(k)
  1878.       l=iabs(ilines)-1
  1879.       k=k+1
  1880.       write (*, 2) (lines(i),i=k,l)
  1881.  2    format(' ',36a2)
  1882.       k=l+1
  1883.       clines=lines(k)
  1884.       if(ilines.ge.0) go to 1
  1885.       return
  1886.       end
  1887.  
  1888.       subroutine pspeak(msg,skip)
  1889. c  find the skip+1st message from msg and print it.  msg should be the index of
  1890. c  the inventory message for object.  (inven+n+1 message is prop=n message).
  1891.       implicit integer*2 (a-z)
  1892.       common /lincom/ lines
  1893.       common /txtcom/ rtext
  1894.       common /ptxcom/ ptext
  1895.       character*2 lines (21150),clines
  1896.       dimension rtext(205),ptext(100)
  1897.       integer*4 mm
  1898.       equivalence (clines,ilines)
  1899.       m=ptext(msg)
  1900.       if(skip.lt.0)goto 9
  1901.       do 3 i=1,skip+1
  1902.  1    mm=m
  1903.       clines=lines(mm)
  1904.       m=iabs(ilines)
  1905.       mm=m
  1906.       clines=lines(mm)
  1907.       if(ilines.ge.0) go to 1
  1908.  3    continue
  1909.  9    call speak(m)
  1910.       return
  1911.       end
  1912.  
  1913.       subroutine rspeak(i)
  1914. c  print the i-th "random" message (section 6 of database).
  1915.       implicit integer*2 (a-z)
  1916.       common /txtcom/ rtext
  1917.       dimension rtext(205)
  1918.       if(i.ne.0)call speak(rtext(i))
  1919.       return
  1920.       end
  1921.  
  1922.       integer*2 function yes(x,y,z)
  1923. c  call yesx (below) with messages from section 6.
  1924.       implicit integer*2 (a-z)
  1925.       yes=yesx(x,y,z)
  1926.       return
  1927.       end
  1928.  
  1929.       integer*2 function yesx(x,y,z)
  1930. c  print message x, wait for yes/no answer.  if yes, print y and leave yea
  1931. c  true; if no, print z and leave yea false.
  1932.       implicit integer*2 (a-z)
  1933.       character*4 reply,junk1,junk2,junk3
  1934.  1    if(x.ne.0) call rspeak (x)
  1935.       call getin(reply,junk1,junk2,junk3)
  1936.       if(reply.eq.'yes '.or.reply.eq.'y   ')goto 10
  1937.       if(reply.eq.'no  '.or.reply.eq.'n   ')goto 20
  1938.       write (*,9)
  1939.  9    format(/' Please answer the question "yes" or "no".')
  1940.       goto 1
  1941.  10   yesx=1
  1942.       if(y.ne.0) call rspeak (y)
  1943.       return
  1944.  20   yesx=0
  1945.       if(z.ne.0) call rspeak (z)
  1946.       return
  1947.       end
  1948.  
  1949.       subroutine a5toa1 (a, b, c, d, chars, leng)
  1950. c   a & b contain a 1 to 8-character word in a4 format.  c & d contain
  1951. c  another word and/or punctuation. they are unpacked to one character
  1952. c  per word in the array "chars", with exactly one blank between b & c
  1953. c  (or none, if c is zero).  the index of the last non-blank character
  1954. c  in chars is returned in leng.
  1955.       implicit integer*2 (a-z)
  1956.       integer*4 ic
  1957.       character *20 aaa
  1958.       character *4 a,b,c,d,aa(5),cc
  1959.       character *1 chars(20),raw(20)
  1960.       equivalence (aaa,aa),(cc,ic)
  1961. c  do first word until a blank
  1962.       aa(1) = a
  1963.       aa(2) = b
  1964.       call unpack (aaa, raw)
  1965. c  clear output array and move, counting to first blank
  1966.       leng=0
  1967.       do 2 i=1,20
  1968. 2     chars(i)=' '
  1969.       do 1 i=1,8
  1970.       if (raw(i).eq.' ') go to 3
  1971.       chars(i)=raw(i)
  1972. 1     leng=i
  1973. c  leng doesn't include trailing blank
  1974. 3     cc=c
  1975.       if(ic.eq.0) go to 99
  1976. c  second word--ignore leading blanks, stop at trailing one
  1977.       chars(leng+1)=' '
  1978.       leng=leng+1
  1979.       ll=leng
  1980.       aa(1)=c
  1981.       aa(2)=d
  1982.       call unpack (aaa,raw)
  1983. c  skip leading blank if any
  1984.       do 4 j=1,8
  1985. 4     if (raw(j).ne.' ') go to 5
  1986. c  second word was all blank--fooey
  1987.       go to 99
  1988. c  do non-blanks
  1989. 5     do 6 k=j,8
  1990.       if (raw(k).eq.' ') go to 99
  1991.       chars (k-j+1+ll) = raw(k)
  1992. 6     leng=leng+1
  1993. 99    return
  1994.       end
  1995. c
  1996.       integer*2 function vocab(id,init)
  1997. c  look up id in the vocabulary (atab) and return its "definition" (ktab), or
  1998. c  -1 if not found.  if init is positive, this is an initialization call setting
  1999. c  up a keyword variable, and not finding it constitutes a bug.  it also means
  2000. c  that only ktab values which taken over 1000 equal init may be considered.
  2001. c  (thus "steps", which is a motion verb also, may be considered
  2002. c  as an object.)  and it also means the ktab value is taken mod 1000.
  2003.       implicit integer*2 (a-z)
  2004.       common /voccom/ ktab,atab,tabsiz
  2005.       character*4 atab(295),id
  2006.       dimension ktab(295)
  2007.       do 1 i=1,tabsiz
  2008.       if(ktab(i).eq.-1)goto 2
  2009.       if(init.ge.0.and.ktab(i)/1000.ne.init)goto 1
  2010.       if(atab(i).eq.id)goto 3
  2011.  1    continue
  2012.  10   format(1x,i4,2x,a4)
  2013.       call bug(21)
  2014.  2    vocab=-1
  2015.       if(init.lt.0)return
  2016.       write (*,10) init, id
  2017.       call bug(5)
  2018.  3    vocab=ktab(i)
  2019.       if(init.ge.0)vocab=mod(vocab,1000)
  2020.       return
  2021.       end
  2022.  
  2023.       subroutine dstroy(object)
  2024. c  permanently eliminate "object" by moving to a non-existent location.
  2025.       implicit integer*2 (a-z)
  2026.       call move(object,0)
  2027.       return
  2028.       end
  2029.  
  2030.       subroutine juggle(object)
  2031. c  juggle an object by picking it up and putting it down again, the purpose
  2032. c  being to get the object to the front of the chain of things at its loc.
  2033.       implicit integer*2 (a-z)
  2034.       common /placom/ atloc,link,place,fixed,holdng
  2035.       dimension atloc(150),link(200),place( 100),fixed(100)
  2036.       i=place(object)
  2037.       call move(object,i)
  2038.       call move(object+100,j)
  2039.       return
  2040.       end
  2041.  
  2042.       subroutine move(object,where)
  2043.  
  2044. c  place any object anywhere by picking it up and dropping it.  may already be
  2045. c  toting, in which case the carry is a no-op.  mustn't pick up objects which
  2046. c  are not at any loc, since carry wants to remove objects from atloc chains.
  2047.       implicit integer*2 (a-z)
  2048.       common /placom/ atloc,link,place,fixed,holdng
  2049.       dimension atloc(150),link(200),place( 100),fixed(100)
  2050.       if(object.gt.100)goto 1
  2051.       from=place(object)
  2052.       goto 2
  2053.  1    from=fixed(object-100)
  2054.  2    if(from.gt.0.and.from.le.300)call carry(object,from)
  2055.       call drop(object,where)
  2056.       return
  2057.       end
  2058.  
  2059.       integer*2 function put(object,where,pval)
  2060.  
  2061. c  put is the same as move, except it returns a value used to set up the
  2062. c  negated prop values for the repository objects.
  2063.       implicit integer*2 (a-z)
  2064.       call move(object,where)
  2065.       put=(-1)-pval
  2066.       return
  2067.       end
  2068.  
  2069.       subroutine carry(object,where)
  2070. c  start toting an object, removing it from the list of things at its former
  2071. c  location.  incr holdng unless it was already being toted.  if object>100
  2072. c  (moving "fixed" second loc), don't change place or holdng.
  2073.       implicit integer*2 (a-z)
  2074.       common /placom/ atloc,link,place,fixed,holdng
  2075.       dimension atloc(150),link(200),place( 100),fixed(100)
  2076.       if(object.gt.100)goto 5
  2077.       if(place(object).eq.-1)return
  2078.       place(object)=-1
  2079.       holdng=holdng+1
  2080.  5    if(atloc(where).ne.object)goto 6
  2081.       atloc(where)=link(object)
  2082.       return
  2083.  6    temp=atloc(where)
  2084.  7    if(link(temp).eq.object)goto 8
  2085.       temp=link(temp)
  2086.       goto 7
  2087.  8    link(temp)=link(object)
  2088.       return
  2089.       end
  2090.  
  2091.       subroutine drop(object,where)
  2092. c  place an object at a given loc, prefixing it onto the atloc list.  decr
  2093. c  holdng if the object was being toted.
  2094.       implicit integer*2 (a-z)
  2095.       common /placom/ atloc,link,place,fixed,holdng
  2096.       dimension atloc(150),link(200),place( 100),fixed(100)
  2097.       if(object.gt.100)goto 1
  2098.       if(place(object).eq.-1)holdng=holdng-1
  2099.       place(object)=where
  2100.       goto 2
  2101.  1    fixed(object-100)=where
  2102.  2    if(where.le.0)return
  2103.       link(object)=atloc(where)
  2104.       atloc(where)=object
  2105.       return
  2106.       end
  2107.  
  2108. c  utility routines (shift, ran, datime, bug)
  2109.       integer*2 function shift (val, dist)
  2110. c return val shifted (left if dist>0, else right) dist bits
  2111.       implicit integer*2 (a-z)
  2112.       shift=val
  2113.       if (dist.eq.0) go to 20
  2114.       idist=iabs(dist)
  2115.       do 1  i = 1,idist
  2116.       if (dist.lt.0) shift=shift/2
  2117. 1     if (dist.gt.0) shift=shift*2
  2118. 20    return
  2119.       end
  2120.       subroutine bug(num)
  2121.       implicit integer*2 (a-z)
  2122.  
  2123. c  the following conditions are currently considered fatal bugs.  numbers < 20
  2124. c  are detected while reading the database; the others occur at "run time".
  2125. c  0      message line > 72 characters                     
  2126. c  1      null line in message                             * Only ones
  2127. c  2      too many words of messages                         currently
  2128. c  3      too many travel options                            implemented
  2129. c  4      too many vocabulary words
  2130. c  5    * required vocabulary word not found
  2131. c  6      too many rtext messages
  2132. c  7      too many hints
  2133. c  8      location has cond bit being set twice
  2134. c  9      invalid section number in database
  2135. c  20   * special travel (500>l>300) exceeds goto list
  2136. c  21   * ran off end of vocabulary table
  2137. c  22   * vocabulary type (n/1000) not between 0 and 3
  2138. c  23   * intransitive action verb exceeds goto list
  2139. c  24     transitive action verb exceeds goto list
  2140. c  25   * conditional travel entry with no alternative
  2141. c  26   * location has no travel entries
  2142. c  27   * hint number exceeds goto list
  2143. c  28     invalid month returned by date function
  2144.  
  2145.       write (*,1) num
  2146.  1    format (' Fatal error, see source code for interpretation.'/
  2147.      . ' Probable cause:  erroneous info in database.'/
  2148.      2 ' Error code =',i2/)
  2149.       pause 'To Exit From Adventure'
  2150.       end
  2151.  
  2152.       subroutine getin (word1,word1x,word2,word2x)
  2153. c  get a command from the adventurer.  snarf out the first word, pad it
  2154. c  with blanks, and return in word1--word1x used for overflow charcters
  2155. c  5-8 in case we need to print the whole word back out in an error.
  2156. c  any number of blanks may follow the word.  if a second word appears
  2157. c  it is returned in word2/word2x, else word2 is set to zero.  all are
  2158. c  converted to lower case for comparison ease (ibm pc version).
  2159.       implicit integer*2 (a-z)
  2160.       common /blkcom/ blklin
  2161.       character*1 s(20), t(20)
  2162.       character*4 word1, word1x, word2, word2x, w1(5), w2(5), a(5)
  2163.       character*20 w81, w82, aa, bb
  2164.       integer*4 iw1, iw1x, iw2, iw2x
  2165.       equivalence (w1(1),iw1),(w1(2),iw1x),(a,aa)
  2166.       equivalence (w2(1),iw2),(w2(2),iw2x),(w81,w1),(w82,w2)
  2167.       if (blklin.eq.1) write (*,1)
  2168. 1     format (1x)
  2169. c  give a prompt to make him think we want input
  2170.       write (*,9)
  2171. 9     format ('   -> ',\)
  2172. c
  2173. c  read twenty characters into a.  unpack them into s.
  2174.       read (*,3) a
  2175. 3     format (5a4)
  2176.       bb = aa
  2177.       call unpack (bb, s)
  2178. c  translate all to lower case
  2179.       do 1001 i=1,20
  2180.       if (ichar(s(i)).lt.65.or.ichar(s(i)).gt.90) go to 1001
  2181.       s(i)=char(ichar(s(i))+32)
  2182. 1001  continue
  2183. c  go through the characters and transfer the first word into t, up
  2184. c  to eight characters
  2185.       do 10 i=1,20
  2186. 10    t(i)=' '
  2187.       do 11 i=1,8
  2188.       if (s(i).eq.' ') go to 20
  2189. 11    t(i)=s(i)
  2190. c  now repack the characters into w81, equivalent to word1,word1x
  2191. 20    call pack (w81,t)
  2192.       word1=w1(1)
  2193.       word1x=w1(2)
  2194. c  now find a second word if one exists--clear return words first
  2195.       iw2=0
  2196.       iw2x=0
  2197.       do 30 i=1,20
  2198. 30    t(i)=' '
  2199.       do 31 i=1,20
  2200.       if (s(i).ne.' ') go to 31
  2201.       go to 32
  2202. 31    continue
  2203. c  all characters--fooey
  2204.       go to 40
  2205. c  hit first blank after first word--now get first non-blank
  2206. 32    do 33 j=i,20
  2207.       if (s(j).eq.' ') go to 33
  2208.       go to 34
  2209. 33    continue
  2210. c  blanked out again
  2211.       go to 40
  2212. c  hit beginning of second word--finish it
  2213. 34    do 35 i=j,20
  2214.       if (s(i).eq.' ') go to 36
  2215. 35    t(i-j+1)=s(i)
  2216. c  now repack word2/2x
  2217. 36    call pack (w82,t)
  2218. 40    word2=w2(1)
  2219.       word2x=w2(2)
  2220.       return
  2221.       end
  2222. c
  2223.       subroutine unpack (b, s)
  2224.       implicit integer*2 (a-z)
  2225. c   unpack general subroutine
  2226. c  b  20 character string
  2227. c  s  20 character*1 singles
  2228.       character*20 a,b
  2229.       character*4 aa(5)
  2230.       integer*4 ia(5)
  2231.       equivalence (ia,a,aa)
  2232.       character*1 s(20)
  2233.       a = b
  2234.       do 1 k = 1,5
  2235.       do 1 j = 1,4
  2236.       s(4*(k-1)+j)=aa(k)
  2237. 1     if(j.ne.4)ia(k)=ia(k)/256
  2238.       return
  2239.       end
  2240. c
  2241.       subroutine pack (b, t)
  2242.       implicit integer*2 (a-z)
  2243. c   general pack subroutine--20 characters
  2244. c   b  return packed word--20
  2245. c   t  array to pack of char*1's
  2246.       character*20 a,b
  2247.       integer*4 ia(5)
  2248.       equivalence (ia,a)
  2249.       character*1 s(20),t(20)
  2250.       do 95 i = 1,20
  2251. 95      s(i)=t(i)
  2252.       do 1 k = 1,5
  2253.       ia(6-k)=0
  2254.       do 1 j = 1, 4
  2255.       l=4*(5-k)+5-j
  2256.       ia(6-k) = ia(6-k) + ichar (s(l))
  2257. 1     if (j.ne.4) ia(6-k) = ia(6-k) * 256
  2258.       b=a
  2259.       return
  2260.       end
  2261. c
  2262.       integer*2 function toting(obj)
  2263.       implicit integer*2 (a-z)
  2264.       common /placom/ atloc,link,place,fixed,holdng
  2265.       dimension atloc(150),link(200),place( 100),fixed(100)
  2266.       toting=0
  2267.       if (place(obj).eq.-1) toting=1
  2268.       return
  2269.       end
  2270. c
  2271.       integer*2 function here(obj)
  2272.       implicit integer*2 (a-z)
  2273.       common /placom/ atloc,link,place,fixed,holdng
  2274.       common /loccom/ loc
  2275.       dimension atloc(150),link(200),place( 100),fixed(100)
  2276.       here=0
  2277.       if (place(obj).eq.loc.or.toting(obj).eq.1) here=1
  2278.       return
  2279.       end
  2280. c
  2281.       integer*2 function at(obj)
  2282.       implicit integer*2 (a-z)
  2283.       common /placom/ atloc,link,place,fixed,holdng
  2284.       common /loccom/ loc
  2285.       dimension atloc(150),link(200),place( 100),fixed(100)
  2286.       at=0
  2287.       if (place(obj).eq.loc.or.fixed(obj).eq.loc) at=1
  2288.       return
  2289.       end
  2290. c
  2291.       integer*2 function forced(loc)
  2292.       implicit integer*2 (a-z)
  2293.       common /concom/ cond
  2294.       dimension cond (150)
  2295.       forced=0
  2296.       if (cond(loc).eq.2) forced=1
  2297.       return
  2298.       end
  2299. c
  2300.       integer*2 function dark(dummy)
  2301.       implicit integer*2 (a-z)
  2302.       common /concom/ cond
  2303.       common /loccom/ loc
  2304.       common /procom/ prop, lamp
  2305.       dimension cond(150),prop(100)
  2306.       external here
  2307.       dark=0
  2308.       if (mod(cond(loc),2).eq.0 .and. (prop(lamp).eq.0 .or.
  2309.      .  here(lamp).eq.0)) dark=1
  2310.       return
  2311.       end
  2312. c
  2313.       integer*2 function pct(n)
  2314.       implicit integer*2 (a-z)
  2315.       external ran
  2316.       pct=0
  2317.       if (ran(100).lt.n) pct=1
  2318.       return
  2319.       end
  2320.  
  2321.       subroutine datime (daye,t)
  2322. c   d is date as number of days (more or less) after jan 1 77
  2323. c   t is time as number of minutes past midnight
  2324.       implicit integer*4 (a-z)
  2325.       call getdat(year,month,day)
  2326.       call gettim(hour,minute,second,hndrth)
  2327.       t=minute+60*hour
  2328.       daye=(year-77)*365+((month-1)*30)+day
  2329.       return
  2330.       end
  2331.  
  2332.       integer*2 function ran(range)
  2333.  
  2334. c  since the ran function in lib40 seems to be a real lose, we'll use one of
  2335. c  our own.  it's been run through many of the tests in knuth vol. 2 and
  2336. c  seems to be quite reliable.  ran returns a value uniformly selected
  2337. c  between 0 and range-1.  note resemblance to alg used in wizard.
  2338.  
  2339.       implicit integer*4 (a-z)
  2340.       integer*2 range
  2341.       data r/-1/
  2342.       d=1
  2343.       if(r.ne.-1)goto 1
  2344.       call datime(d,t)
  2345.       r=18*t+5
  2346.       d=1000+mod(d,1000)
  2347.  1    do 2 t=1,d
  2348.  2    r=mod(r*1021,1048576)
  2349.       rn=(range*r)/1048576
  2350.       ran=rn
  2351.       return
  2352.       end
  2353.  
  2354. c  ======= end =======
  2355.